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))
 978         if (itypi.eq.ntyp1) cycle
 979         itypi1=iabs(itype(i+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))
 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),i,restyp(itypj),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))
1136         if (itypi.eq.ntyp1) cycle
1137         itypi1=iabs(itype(i+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))
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),i,restyp(itypj),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))
1237         if (itypi.eq.ntyp1) cycle
1238         itypi1=iabs(itype(i+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))
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),i,restyp(itypj),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))
1369 !        if (i.ne.47) cycle
1370         if (itypi.eq.ntyp1) cycle
1371         itypi1=iabs(itype(i+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))
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),itype(j)
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),i,restyp(itypj),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),i,restyp(itypj),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))
1682         if (itypi.eq.ntyp1) cycle
1683         itypi1=iabs(itype(i+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))
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),i,restyp(itypj),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))
1814         if (itypi.eq.ntyp1) cycle
1815         itypi1=iabs(itype(i+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))
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).eq.ntyp1 .or. itype(i+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).eq.ntyp1 .or. itype(j+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))
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))
2350         else
2351           iti1=ntortyp+1
2352         endif
2353 !          print *,iti,i,"iti",iti1,itype(i-1),itype(i-2)
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).le.ntyp) then
2391             iti1 = itortyp(itype(i-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))
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).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2855         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).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).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2901           .or. itype(i+3).eq.ntyp1 &
2902           .or. itype(i+4).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).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).eq.ntyp1 .or. itype(i+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),itype(j)
2994           if (itype(j).eq.ntyp1.or. itype(j+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)),j,itortyp(itype(j)),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))
4330         iti2=itortyp(itype(i+2))
4331         iti3=itortyp(itype(i+3))
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).eq.ntyp1 .or. itype(i+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).eq.ntyp1) cycle
4610           itypj=iabs(itype(j))
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).eq.ntyp1 .or. itype(i+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))
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)).eq.1 .and. &
4896         iabs(itype(jjj)).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))
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))
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).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5124         if (itype(i-1).eq.ntyp1 .or. itype(i).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))
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             do j=1,3
5188              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5189             enddo
5190           endif
5191         endif
5192       enddo
5193       return
5194       end subroutine ebond
5195 #ifdef CRYST_THETA
5196 !-----------------------------------------------------------------------------
5197       subroutine ebend(etheta)
5198 !
5199 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5200 ! angles gamma and its derivatives in consecutive thetas and gammas.
5201 !
5202       use comm_calcthet
5203 !      implicit real*8 (a-h,o-z)
5204 !      include 'DIMENSIONS'
5205 !      include 'COMMON.LOCAL'
5206 !      include 'COMMON.GEO'
5207 !      include 'COMMON.INTERACT'
5208 !      include 'COMMON.DERIV'
5209 !      include 'COMMON.VAR'
5210 !      include 'COMMON.CHAIN'
5211 !      include 'COMMON.IOUNITS'
5212 !      include 'COMMON.NAMES'
5213 !      include 'COMMON.FFIELD'
5214 !      include 'COMMON.CONTROL'
5215 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5216 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5217 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5218 !el      integer :: it
5219 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5220 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5221 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5222 !el local variables
5223       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5224        ichir21,ichir22
5225       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5226        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5227        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5228       real(kind=8),dimension(2) :: y,z
5229
5230       delta=0.02d0*pi
5231 !      time11=dexp(-2*time)
5232 !      time12=1.0d0
5233       etheta=0.0D0
5234 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5235       do i=ithet_start,ithet_end
5236         if (itype(i-1).eq.ntyp1) cycle
5237 ! Zero the energy function and its derivative at 0 or pi.
5238         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5239         it=itype(i-1)
5240         ichir1=isign(1,itype(i-2))
5241         ichir2=isign(1,itype(i))
5242          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5243          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5244          if (itype(i-1).eq.10) then
5245           itype1=isign(10,itype(i-2))
5246           ichir11=isign(1,itype(i-2))
5247           ichir12=isign(1,itype(i-2))
5248           itype2=isign(10,itype(i))
5249           ichir21=isign(1,itype(i))
5250           ichir22=isign(1,itype(i))
5251          endif
5252
5253         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
5254 #ifdef OSF
5255           phii=phi(i)
5256           if (phii.ne.phii) phii=150.0
5257 #else
5258           phii=phi(i)
5259 #endif
5260           y(1)=dcos(phii)
5261           y(2)=dsin(phii)
5262         else
5263           y(1)=0.0D0
5264           y(2)=0.0D0
5265         endif
5266         if (i.lt.nres .and. itype(i).ne.ntyp1) then
5267 #ifdef OSF
5268           phii1=phi(i+1)
5269           if (phii1.ne.phii1) phii1=150.0
5270           phii1=pinorm(phii1)
5271           z(1)=cos(phii1)
5272 #else
5273           phii1=phi(i+1)
5274           z(1)=dcos(phii1)
5275 #endif
5276           z(2)=dsin(phii1)
5277         else
5278           z(1)=0.0D0
5279           z(2)=0.0D0
5280         endif
5281 ! Calculate the "mean" value of theta from the part of the distribution
5282 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5283 ! In following comments this theta will be referred to as t_c.
5284         thet_pred_mean=0.0d0
5285         do k=1,2
5286             athetk=athet(k,it,ichir1,ichir2)
5287             bthetk=bthet(k,it,ichir1,ichir2)
5288           if (it.eq.10) then
5289              athetk=athet(k,itype1,ichir11,ichir12)
5290              bthetk=bthet(k,itype2,ichir21,ichir22)
5291           endif
5292          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5293         enddo
5294         dthett=thet_pred_mean*ssd
5295         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5296 ! Derivatives of the "mean" values in gamma1 and gamma2.
5297         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5298                +athet(2,it,ichir1,ichir2)*y(1))*ss
5299         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5300                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5301          if (it.eq.10) then
5302         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5303              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5304         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5305                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5306          endif
5307         if (theta(i).gt.pi-delta) then
5308           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5309                E_tc0)
5310           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5311           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5312           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5313               E_theta)
5314           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5315               E_tc)
5316         else if (theta(i).lt.delta) then
5317           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5318           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5319           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5320               E_theta)
5321           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5322           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5323               E_tc)
5324         else
5325           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5326               E_theta,E_tc)
5327         endif
5328         etheta=etheta+ethetai
5329         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5330             'ebend',i,ethetai
5331         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5332         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5333         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5334       enddo
5335 ! Ufff.... We've done all this!!!
5336       return
5337       end subroutine ebend
5338 !-----------------------------------------------------------------------------
5339       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5340
5341       use comm_calcthet
5342 !      implicit real*8 (a-h,o-z)
5343 !      include 'DIMENSIONS'
5344 !      include 'COMMON.LOCAL'
5345 !      include 'COMMON.IOUNITS'
5346 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5347 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5348 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5349       integer :: i,j,k
5350       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5351 !el      integer :: it
5352 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5353 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5354 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5355 !el local variables
5356       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5357        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5358
5359 ! Calculate the contributions to both Gaussian lobes.
5360 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5361 ! The "polynomial part" of the "standard deviation" of this part of
5362 ! the distribution.
5363         sig=polthet(3,it)
5364         do j=2,0,-1
5365           sig=sig*thet_pred_mean+polthet(j,it)
5366         enddo
5367 ! Derivative of the "interior part" of the "standard deviation of the"
5368 ! gamma-dependent Gaussian lobe in t_c.
5369         sigtc=3*polthet(3,it)
5370         do j=2,1,-1
5371           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5372         enddo
5373         sigtc=sig*sigtc
5374 ! Set the parameters of both Gaussian lobes of the distribution.
5375 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5376         fac=sig*sig+sigc0(it)
5377         sigcsq=fac+fac
5378         sigc=1.0D0/sigcsq
5379 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5380         sigsqtc=-4.0D0*sigcsq*sigtc
5381 !       print *,i,sig,sigtc,sigsqtc
5382 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5383         sigtc=-sigtc/(fac*fac)
5384 ! Following variable is sigma(t_c)**(-2)
5385         sigcsq=sigcsq*sigcsq
5386         sig0i=sig0(it)
5387         sig0inv=1.0D0/sig0i**2
5388         delthec=thetai-thet_pred_mean
5389         delthe0=thetai-theta0i
5390         term1=-0.5D0*sigcsq*delthec*delthec
5391         term2=-0.5D0*sig0inv*delthe0*delthe0
5392 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5393 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5394 ! to the energy (this being the log of the distribution) at the end of energy
5395 ! term evaluation for this virtual-bond angle.
5396         if (term1.gt.term2) then
5397           termm=term1
5398           term2=dexp(term2-termm)
5399           term1=1.0d0
5400         else
5401           termm=term2
5402           term1=dexp(term1-termm)
5403           term2=1.0d0
5404         endif
5405 ! The ratio between the gamma-independent and gamma-dependent lobes of
5406 ! the distribution is a Gaussian function of thet_pred_mean too.
5407         diffak=gthet(2,it)-thet_pred_mean
5408         ratak=diffak/gthet(3,it)**2
5409         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5410 ! Let's differentiate it in thet_pred_mean NOW.
5411         aktc=ak*ratak
5412 ! Now put together the distribution terms to make complete distribution.
5413         termexp=term1+ak*term2
5414         termpre=sigc+ak*sig0i
5415 ! Contribution of the bending energy from this theta is just the -log of
5416 ! the sum of the contributions from the two lobes and the pre-exponential
5417 ! factor. Simple enough, isn't it?
5418         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5419 ! NOW the derivatives!!!
5420 ! 6/6/97 Take into account the deformation.
5421         E_theta=(delthec*sigcsq*term1 &
5422              +ak*delthe0*sig0inv*term2)/termexp
5423         E_tc=((sigtc+aktc*sig0i)/termpre &
5424             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5425              aktc*term2)/termexp)
5426       return
5427       end subroutine theteng
5428 #else
5429 !-----------------------------------------------------------------------------
5430       subroutine ebend(etheta,ethetacnstr)
5431 !
5432 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5433 ! angles gamma and its derivatives in consecutive thetas and gammas.
5434 ! ab initio-derived potentials from
5435 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5436 !
5437 !      implicit real*8 (a-h,o-z)
5438 !      include 'DIMENSIONS'
5439 !      include 'COMMON.LOCAL'
5440 !      include 'COMMON.GEO'
5441 !      include 'COMMON.INTERACT'
5442 !      include 'COMMON.DERIV'
5443 !      include 'COMMON.VAR'
5444 !      include 'COMMON.CHAIN'
5445 !      include 'COMMON.IOUNITS'
5446 !      include 'COMMON.NAMES'
5447 !      include 'COMMON.FFIELD'
5448 !      include 'COMMON.CONTROL'
5449       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5450       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5451       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5452       logical :: lprn=.false., lprn1=.false.
5453 !el local variables
5454       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5455       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5456       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5457 ! local variables for constrains
5458       real(kind=8) :: difi,thetiii
5459        integer itheta
5460
5461       etheta=0.0D0
5462       do i=ithet_start,ithet_end
5463         if (itype(i-1).eq.ntyp1) cycle
5464         if (itype(i-2).eq.ntyp1.or.itype(i).eq.ntyp1) cycle
5465         if (iabs(itype(i+1)).eq.20) iblock=2
5466         if (iabs(itype(i+1)).ne.20) iblock=1
5467         dethetai=0.0d0
5468         dephii=0.0d0
5469         dephii1=0.0d0
5470         theti2=0.5d0*theta(i)
5471         ityp2=ithetyp((itype(i-1)))
5472         do k=1,nntheterm
5473           coskt(k)=dcos(k*theti2)
5474           sinkt(k)=dsin(k*theti2)
5475         enddo
5476         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
5477 #ifdef OSF
5478           phii=phi(i)
5479           if (phii.ne.phii) phii=150.0
5480 #else
5481           phii=phi(i)
5482 #endif
5483           ityp1=ithetyp((itype(i-2)))
5484 ! propagation of chirality for glycine type
5485           do k=1,nsingle
5486             cosph1(k)=dcos(k*phii)
5487             sinph1(k)=dsin(k*phii)
5488           enddo
5489         else
5490           phii=0.0d0
5491           ityp1=ithetyp(itype(i-2))
5492           do k=1,nsingle
5493             cosph1(k)=0.0d0
5494             sinph1(k)=0.0d0
5495           enddo
5496         endif
5497         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5498 #ifdef OSF
5499           phii1=phi(i+1)
5500           if (phii1.ne.phii1) phii1=150.0
5501           phii1=pinorm(phii1)
5502 #else
5503           phii1=phi(i+1)
5504 #endif
5505           ityp3=ithetyp((itype(i)))
5506           do k=1,nsingle
5507             cosph2(k)=dcos(k*phii1)
5508             sinph2(k)=dsin(k*phii1)
5509           enddo
5510         else
5511           phii1=0.0d0
5512           ityp3=ithetyp(itype(i))
5513           do k=1,nsingle
5514             cosph2(k)=0.0d0
5515             sinph2(k)=0.0d0
5516           enddo
5517         endif
5518         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5519         do k=1,ndouble
5520           do l=1,k-1
5521             ccl=cosph1(l)*cosph2(k-l)
5522             ssl=sinph1(l)*sinph2(k-l)
5523             scl=sinph1(l)*cosph2(k-l)
5524             csl=cosph1(l)*sinph2(k-l)
5525             cosph1ph2(l,k)=ccl-ssl
5526             cosph1ph2(k,l)=ccl+ssl
5527             sinph1ph2(l,k)=scl+csl
5528             sinph1ph2(k,l)=scl-csl
5529           enddo
5530         enddo
5531         if (lprn) then
5532         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5533           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5534         write (iout,*) "coskt and sinkt"
5535         do k=1,nntheterm
5536           write (iout,*) k,coskt(k),sinkt(k)
5537         enddo
5538         endif
5539         do k=1,ntheterm
5540           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5541           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5542             *coskt(k)
5543           if (lprn) &
5544           write (iout,*) "k",k,&
5545            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5546            " ethetai",ethetai
5547         enddo
5548         if (lprn) then
5549         write (iout,*) "cosph and sinph"
5550         do k=1,nsingle
5551           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5552         enddo
5553         write (iout,*) "cosph1ph2 and sinph2ph2"
5554         do k=2,ndouble
5555           do l=1,k-1
5556             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5557                sinph1ph2(l,k),sinph1ph2(k,l)
5558           enddo
5559         enddo
5560         write(iout,*) "ethetai",ethetai
5561         endif
5562         do m=1,ntheterm2
5563           do k=1,nsingle
5564             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5565                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5566                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5567                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5568             ethetai=ethetai+sinkt(m)*aux
5569             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5570             dephii=dephii+k*sinkt(m)* &
5571                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5572                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5573             dephii1=dephii1+k*sinkt(m)* &
5574                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5575                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5576             if (lprn) &
5577             write (iout,*) "m",m," k",k," bbthet", &
5578                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5579                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5580                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5581                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5582           enddo
5583         enddo
5584         if (lprn) &
5585         write(iout,*) "ethetai",ethetai
5586         do m=1,ntheterm3
5587           do k=2,ndouble
5588             do l=1,k-1
5589               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5590                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5591                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5592                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5593               ethetai=ethetai+sinkt(m)*aux
5594               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5595               dephii=dephii+l*sinkt(m)* &
5596                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5597                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5598                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5599                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5600               dephii1=dephii1+(k-l)*sinkt(m)* &
5601                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5602                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5603                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5604                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5605               if (lprn) then
5606               write (iout,*) "m",m," k",k," l",l," ffthet",&
5607                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5608                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5609                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5610                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5611                   " ethetai",ethetai
5612               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5613                   cosph1ph2(k,l)*sinkt(m),&
5614                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5615               endif
5616             enddo
5617           enddo
5618         enddo
5619 10      continue
5620 !        lprn1=.true.
5621         if (lprn1) &
5622           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5623          i,theta(i)*rad2deg,phii*rad2deg,&
5624          phii1*rad2deg,ethetai
5625 !        lprn1=.false.
5626         etheta=etheta+ethetai
5627         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5628                                     'ebend',i,ethetai
5629         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5630         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5631         gloc(nphi+i-2,icg)=wang*dethetai
5632       enddo
5633 !-----------thete constrains
5634 !      if (tor_mode.ne.2) then
5635       ethetacnstr=0.0d0
5636 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5637       do i=ithetaconstr_start,ithetaconstr_end
5638         itheta=itheta_constr(i)
5639         thetiii=theta(itheta)
5640         difi=pinorm(thetiii-theta_constr0(i))
5641         if (difi.gt.theta_drange(i)) then
5642           difi=difi-theta_drange(i)
5643           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5644           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5645          +for_thet_constr(i)*difi**3
5646         else if (difi.lt.-drange(i)) then
5647           difi=difi+drange(i)
5648           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5649           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5650          +for_thet_constr(i)*difi**3
5651         else
5652           difi=0.0
5653         endif
5654        if (energy_dec) then
5655         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5656          i,itheta,rad2deg*thetiii, &
5657          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5658          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5659          gloc(itheta+nphi-2,icg)
5660         endif
5661       enddo
5662 !      endif
5663
5664       return
5665       end subroutine ebend
5666 #endif
5667 #ifdef CRYST_SC
5668 !-----------------------------------------------------------------------------
5669       subroutine esc(escloc)
5670 ! Calculate the local energy of a side chain and its derivatives in the
5671 ! corresponding virtual-bond valence angles THETA and the spherical angles
5672 ! ALPHA and OMEGA.
5673 !
5674       use comm_sccalc
5675 !      implicit real*8 (a-h,o-z)
5676 !      include 'DIMENSIONS'
5677 !      include 'COMMON.GEO'
5678 !      include 'COMMON.LOCAL'
5679 !      include 'COMMON.VAR'
5680 !      include 'COMMON.INTERACT'
5681 !      include 'COMMON.DERIV'
5682 !      include 'COMMON.CHAIN'
5683 !      include 'COMMON.IOUNITS'
5684 !      include 'COMMON.NAMES'
5685 !      include 'COMMON.FFIELD'
5686 !      include 'COMMON.CONTROL'
5687       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5688          ddersc0,ddummy,xtemp,temp
5689 !el      real(kind=8) :: time11,time12,time112,theti
5690       real(kind=8) :: escloc,delta
5691 !el      integer :: it,nlobit
5692 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5693 !el local variables
5694       integer :: i,k
5695       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5696        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5697       delta=0.02d0*pi
5698       escloc=0.0D0
5699 !     write (iout,'(a)') 'ESC'
5700       do i=loc_start,loc_end
5701         it=itype(i)
5702         if (it.eq.ntyp1) cycle
5703         if (it.eq.10) goto 1
5704         nlobit=nlob(iabs(it))
5705 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5706 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5707         theti=theta(i+1)-pipol
5708         x(1)=dtan(theti)
5709         x(2)=alph(i)
5710         x(3)=omeg(i)
5711
5712         if (x(2).gt.pi-delta) then
5713           xtemp(1)=x(1)
5714           xtemp(2)=pi-delta
5715           xtemp(3)=x(3)
5716           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5717           xtemp(2)=pi
5718           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5719           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5720               escloci,dersc(2))
5721           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5722               ddersc0(1),dersc(1))
5723           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5724               ddersc0(3),dersc(3))
5725           xtemp(2)=pi-delta
5726           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5727           xtemp(2)=pi
5728           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5729           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5730                   dersc0(2),esclocbi,dersc02)
5731           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5732                   dersc12,dersc01)
5733           call splinthet(x(2),0.5d0*delta,ss,ssd)
5734           dersc0(1)=dersc01
5735           dersc0(2)=dersc02
5736           dersc0(3)=0.0d0
5737           do k=1,3
5738             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5739           enddo
5740           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5741 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5742 !    &             esclocbi,ss,ssd
5743           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5744 !         escloci=esclocbi
5745 !         write (iout,*) escloci
5746         else if (x(2).lt.delta) then
5747           xtemp(1)=x(1)
5748           xtemp(2)=delta
5749           xtemp(3)=x(3)
5750           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5751           xtemp(2)=0.0d0
5752           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5753           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
5754               escloci,dersc(2))
5755           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5756               ddersc0(1),dersc(1))
5757           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
5758               ddersc0(3),dersc(3))
5759           xtemp(2)=delta
5760           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5761           xtemp(2)=0.0d0
5762           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5763           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
5764                   dersc0(2),esclocbi,dersc02)
5765           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5766                   dersc12,dersc01)
5767           dersc0(1)=dersc01
5768           dersc0(2)=dersc02
5769           dersc0(3)=0.0d0
5770           call splinthet(x(2),0.5d0*delta,ss,ssd)
5771           do k=1,3
5772             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5773           enddo
5774           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5775 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5776 !    &             esclocbi,ss,ssd
5777           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5778 !         write (iout,*) escloci
5779         else
5780           call enesc(x,escloci,dersc,ddummy,.false.)
5781         endif
5782
5783         escloc=escloc+escloci
5784         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5785            'escloc',i,escloci
5786 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5787
5788         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
5789          wscloc*dersc(1)
5790         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5791         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5792     1   continue
5793       enddo
5794       return
5795       end subroutine esc
5796 !-----------------------------------------------------------------------------
5797       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5798
5799       use comm_sccalc
5800 !      implicit real*8 (a-h,o-z)
5801 !      include 'DIMENSIONS'
5802 !      include 'COMMON.GEO'
5803 !      include 'COMMON.LOCAL'
5804 !      include 'COMMON.IOUNITS'
5805 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5806       real(kind=8),dimension(3) :: x,z,dersc,ddersc
5807       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
5808       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
5809       real(kind=8) :: escloci
5810       logical :: mixed
5811 !el local variables
5812       integer :: j,iii,l,k !el,it,nlobit
5813       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
5814 !el       time11,time12,time112
5815 !       write (iout,*) 'it=',it,' nlobit=',nlobit
5816         escloc_i=0.0D0
5817         do j=1,3
5818           dersc(j)=0.0D0
5819           if (mixed) ddersc(j)=0.0d0
5820         enddo
5821         x3=x(3)
5822
5823 ! Because of periodicity of the dependence of the SC energy in omega we have
5824 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5825 ! To avoid underflows, first compute & store the exponents.
5826
5827         do iii=-1,1
5828
5829           x(3)=x3+iii*dwapi
5830
5831           do j=1,nlobit
5832             do k=1,3
5833               z(k)=x(k)-censc(k,j,it)
5834             enddo
5835             do k=1,3
5836               Axk=0.0D0
5837               do l=1,3
5838                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5839               enddo
5840               Ax(k,j,iii)=Axk
5841             enddo
5842             expfac=0.0D0
5843             do k=1,3
5844               expfac=expfac+Ax(k,j,iii)*z(k)
5845             enddo
5846             contr(j,iii)=expfac
5847           enddo ! j
5848
5849         enddo ! iii
5850
5851         x(3)=x3
5852 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5853 ! subsequent NaNs and INFs in energy calculation.
5854 ! Find the largest exponent
5855         emin=contr(1,-1)
5856         do iii=-1,1
5857           do j=1,nlobit
5858             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5859           enddo
5860         enddo
5861         emin=0.5D0*emin
5862 !d      print *,'it=',it,' emin=',emin
5863
5864 ! Compute the contribution to SC energy and derivatives
5865         do iii=-1,1
5866
5867           do j=1,nlobit
5868 #ifdef OSF
5869             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5870             if(adexp.ne.adexp) adexp=1.0
5871             expfac=dexp(adexp)
5872 #else
5873             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5874 #endif
5875 !d          print *,'j=',j,' expfac=',expfac
5876             escloc_i=escloc_i+expfac
5877             do k=1,3
5878               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5879             enddo
5880             if (mixed) then
5881               do k=1,3,2
5882                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
5883                   +gaussc(k,2,j,it))*expfac
5884               enddo
5885             endif
5886           enddo
5887
5888         enddo ! iii
5889
5890         dersc(1)=dersc(1)/cos(theti)**2
5891         ddersc(1)=ddersc(1)/cos(theti)**2
5892         ddersc(3)=ddersc(3)
5893
5894         escloci=-(dlog(escloc_i)-emin)
5895         do j=1,3
5896           dersc(j)=dersc(j)/escloc_i
5897         enddo
5898         if (mixed) then
5899           do j=1,3,2
5900             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5901           enddo
5902         endif
5903       return
5904       end subroutine enesc
5905 !-----------------------------------------------------------------------------
5906       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5907
5908       use comm_sccalc
5909 !      implicit real*8 (a-h,o-z)
5910 !      include 'DIMENSIONS'
5911 !      include 'COMMON.GEO'
5912 !      include 'COMMON.LOCAL'
5913 !      include 'COMMON.IOUNITS'
5914 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5915       real(kind=8),dimension(3) :: x,z,dersc
5916       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
5917       real(kind=8),dimension(nlobit) :: contr !(maxlob)
5918       real(kind=8) :: escloci,dersc12,emin
5919       logical :: mixed
5920 !el local varables
5921       integer :: j,k,l !el,it,nlobit
5922       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
5923
5924       escloc_i=0.0D0
5925
5926       do j=1,3
5927         dersc(j)=0.0D0
5928       enddo
5929
5930       do j=1,nlobit
5931         do k=1,2
5932           z(k)=x(k)-censc(k,j,it)
5933         enddo
5934         z(3)=dwapi
5935         do k=1,3
5936           Axk=0.0D0
5937           do l=1,3
5938             Axk=Axk+gaussc(l,k,j,it)*z(l)
5939           enddo
5940           Ax(k,j)=Axk
5941         enddo
5942         expfac=0.0D0
5943         do k=1,3
5944           expfac=expfac+Ax(k,j)*z(k)
5945         enddo
5946         contr(j)=expfac
5947       enddo ! j
5948
5949 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5950 ! subsequent NaNs and INFs in energy calculation.
5951 ! Find the largest exponent
5952       emin=contr(1)
5953       do j=1,nlobit
5954         if (emin.gt.contr(j)) emin=contr(j)
5955       enddo
5956       emin=0.5D0*emin
5957
5958 ! Compute the contribution to SC energy and derivatives
5959
5960       dersc12=0.0d0
5961       do j=1,nlobit
5962         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5963         escloc_i=escloc_i+expfac
5964         do k=1,2
5965           dersc(k)=dersc(k)+Ax(k,j)*expfac
5966         enddo
5967         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
5968                   +gaussc(1,2,j,it))*expfac
5969         dersc(3)=0.0d0
5970       enddo
5971
5972       dersc(1)=dersc(1)/cos(theti)**2
5973       dersc12=dersc12/cos(theti)**2
5974       escloci=-(dlog(escloc_i)-emin)
5975       do j=1,2
5976         dersc(j)=dersc(j)/escloc_i
5977       enddo
5978       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5979       return
5980       end subroutine enesc_bound
5981 #else
5982 !-----------------------------------------------------------------------------
5983       subroutine esc(escloc)
5984 ! Calculate the local energy of a side chain and its derivatives in the
5985 ! corresponding virtual-bond valence angles THETA and the spherical angles
5986 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
5987 ! added by Urszula Kozlowska. 07/11/2007
5988 !
5989       use comm_sccalc
5990 !      implicit real*8 (a-h,o-z)
5991 !      include 'DIMENSIONS'
5992 !      include 'COMMON.GEO'
5993 !      include 'COMMON.LOCAL'
5994 !      include 'COMMON.VAR'
5995 !      include 'COMMON.SCROT'
5996 !      include 'COMMON.INTERACT'
5997 !      include 'COMMON.DERIV'
5998 !      include 'COMMON.CHAIN'
5999 !      include 'COMMON.IOUNITS'
6000 !      include 'COMMON.NAMES'
6001 !      include 'COMMON.FFIELD'
6002 !      include 'COMMON.CONTROL'
6003 !      include 'COMMON.VECTORS'
6004       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6005       real(kind=8),dimension(65) :: x
6006       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6007          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6008       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6009       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6010          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6011 !el local variables
6012       integer :: i,j,k !el,it,nlobit
6013       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6014 !el      real(kind=8) :: time11,time12,time112,theti
6015 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6016       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6017                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6018                    sumene1x,sumene2x,sumene3x,sumene4x,&
6019                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6020                    cosfac2xx,sinfac2yy
6021 #ifdef DEBUG
6022       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6023                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6024                    de_dt_num
6025 #endif
6026 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6027
6028       delta=0.02d0*pi
6029       escloc=0.0D0
6030       do i=loc_start,loc_end
6031         if (itype(i).eq.ntyp1) cycle
6032         costtab(i+1) =dcos(theta(i+1))
6033         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6034         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6035         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6036         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6037         cosfac=dsqrt(cosfac2)
6038         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6039         sinfac=dsqrt(sinfac2)
6040         it=iabs(itype(i))
6041         if (it.eq.10) goto 1
6042 !
6043 !  Compute the axes of tghe local cartesian coordinates system; store in
6044 !   x_prime, y_prime and z_prime
6045 !
6046         do j=1,3
6047           x_prime(j) = 0.00
6048           y_prime(j) = 0.00
6049           z_prime(j) = 0.00
6050         enddo
6051 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6052 !     &   dc_norm(3,i+nres)
6053         do j = 1,3
6054           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6055           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6056         enddo
6057         do j = 1,3
6058           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6059         enddo
6060 !       write (2,*) "i",i
6061 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6062 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6063 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6064 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6065 !      & " xy",scalar(x_prime(1),y_prime(1)),
6066 !      & " xz",scalar(x_prime(1),z_prime(1)),
6067 !      & " yy",scalar(y_prime(1),y_prime(1)),
6068 !      & " yz",scalar(y_prime(1),z_prime(1)),
6069 !      & " zz",scalar(z_prime(1),z_prime(1))
6070 !
6071 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6072 ! to local coordinate system. Store in xx, yy, zz.
6073 !
6074         xx=0.0d0
6075         yy=0.0d0
6076         zz=0.0d0
6077         do j = 1,3
6078           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6079           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6080           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6081         enddo
6082
6083         xxtab(i)=xx
6084         yytab(i)=yy
6085         zztab(i)=zz
6086 !
6087 ! Compute the energy of the ith side cbain
6088 !
6089 !        write (2,*) "xx",xx," yy",yy," zz",zz
6090         it=iabs(itype(i))
6091         do j = 1,65
6092           x(j) = sc_parmin(j,it)
6093         enddo
6094 #ifdef CHECK_COORD
6095 !c diagnostics - remove later
6096         xx1 = dcos(alph(2))
6097         yy1 = dsin(alph(2))*dcos(omeg(2))
6098         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6099         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6100           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6101           xx1,yy1,zz1
6102 !,"  --- ", xx_w,yy_w,zz_w
6103 ! end diagnostics
6104 #endif
6105         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6106          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6107          + x(10)*yy*zz
6108         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6109          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6110          + x(20)*yy*zz
6111         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6112          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6113          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6114          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6115          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6116          +x(40)*xx*yy*zz
6117         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6118          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6119          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6120          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6121          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6122          +x(60)*xx*yy*zz
6123         dsc_i   = 0.743d0+x(61)
6124         dp2_i   = 1.9d0+x(62)
6125         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6126                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6127         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6128                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6129         s1=(1+x(63))/(0.1d0 + dscp1)
6130         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6131         s2=(1+x(65))/(0.1d0 + dscp2)
6132         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6133         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6134       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6135 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6136 !     &   sumene4,
6137 !     &   dscp1,dscp2,sumene
6138 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6139         escloc = escloc + sumene
6140 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6141 !     & ,zz,xx,yy
6142 !#define DEBUG
6143 #ifdef DEBUG
6144 !
6145 ! This section to check the numerical derivatives of the energy of ith side
6146 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6147 ! #define DEBUG in the code to turn it on.
6148 !
6149         write (2,*) "sumene               =",sumene
6150         aincr=1.0d-7
6151         xxsave=xx
6152         xx=xx+aincr
6153         write (2,*) xx,yy,zz
6154         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6155         de_dxx_num=(sumenep-sumene)/aincr
6156         xx=xxsave
6157         write (2,*) "xx+ sumene from enesc=",sumenep
6158         yysave=yy
6159         yy=yy+aincr
6160         write (2,*) xx,yy,zz
6161         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6162         de_dyy_num=(sumenep-sumene)/aincr
6163         yy=yysave
6164         write (2,*) "yy+ sumene from enesc=",sumenep
6165         zzsave=zz
6166         zz=zz+aincr
6167         write (2,*) xx,yy,zz
6168         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6169         de_dzz_num=(sumenep-sumene)/aincr
6170         zz=zzsave
6171         write (2,*) "zz+ sumene from enesc=",sumenep
6172         costsave=cost2tab(i+1)
6173         sintsave=sint2tab(i+1)
6174         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6175         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6176         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6177         de_dt_num=(sumenep-sumene)/aincr
6178         write (2,*) " t+ sumene from enesc=",sumenep
6179         cost2tab(i+1)=costsave
6180         sint2tab(i+1)=sintsave
6181 ! End of diagnostics section.
6182 #endif
6183 !
6184 ! Compute the gradient of esc
6185 !
6186 !        zz=zz*dsign(1.0,dfloat(itype(i)))
6187         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6188         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6189         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6190         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6191         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6192         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6193         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6194         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6195         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6196            *(pom_s1/dscp1+pom_s16*dscp1**4)
6197         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6198            *(pom_s2/dscp2+pom_s26*dscp2**4)
6199         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6200         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6201         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6202         +x(40)*yy*zz
6203         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6204         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6205         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6206         +x(60)*yy*zz
6207         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6208               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6209               +(pom1+pom2)*pom_dx
6210 #ifdef DEBUG
6211         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6212 #endif
6213 !
6214         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6215         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6216         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6217         +x(40)*xx*zz
6218         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6219         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6220         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6221         +x(59)*zz**2 +x(60)*xx*zz
6222         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6223               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6224               +(pom1-pom2)*pom_dy
6225 #ifdef DEBUG
6226         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6227 #endif
6228 !
6229         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6230         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6231         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6232         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6233         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6234         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6235         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6236         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6237 #ifdef DEBUG
6238         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6239 #endif
6240 !
6241         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6242         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6243         +pom1*pom_dt1+pom2*pom_dt2
6244 #ifdef DEBUG
6245         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6246 #endif
6247 !
6248 !
6249        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6250        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6251        cosfac2xx=cosfac2*xx
6252        sinfac2yy=sinfac2*yy
6253        do k = 1,3
6254          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6255             vbld_inv(i+1)
6256          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6257             vbld_inv(i)
6258          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6259          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6260 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6261 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6262 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6263 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6264          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6265          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6266          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6267          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6268          dZZ_Ci1(k)=0.0d0
6269          dZZ_Ci(k)=0.0d0
6270          do j=1,3
6271            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6272            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6273            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6274            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6275          enddo
6276
6277          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6278          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6279          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6280          (z_prime(k)-zz*dC_norm(k,i+nres))
6281 !
6282          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6283          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6284        enddo
6285
6286        do k=1,3
6287          dXX_Ctab(k,i)=dXX_Ci(k)
6288          dXX_C1tab(k,i)=dXX_Ci1(k)
6289          dYY_Ctab(k,i)=dYY_Ci(k)
6290          dYY_C1tab(k,i)=dYY_Ci1(k)
6291          dZZ_Ctab(k,i)=dZZ_Ci(k)
6292          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6293          dXX_XYZtab(k,i)=dXX_XYZ(k)
6294          dYY_XYZtab(k,i)=dYY_XYZ(k)
6295          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6296        enddo
6297
6298        do k = 1,3
6299 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6300 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6301 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6302 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6303 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6304 !     &    dt_dci(k)
6305 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6306 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6307          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6308           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6309          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6310           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6311          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6312           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6313        enddo
6314 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6315 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6316
6317 ! to check gradient call subroutine check_grad
6318
6319     1 continue
6320       enddo
6321       return
6322       end subroutine esc
6323 !-----------------------------------------------------------------------------
6324       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6325 !      implicit none
6326       real(kind=8),dimension(65) :: x
6327       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6328         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6329
6330       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6331         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6332         + x(10)*yy*zz
6333       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6334         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6335         + x(20)*yy*zz
6336       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6337         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6338         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6339         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6340         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6341         +x(40)*xx*yy*zz
6342       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6343         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6344         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6345         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6346         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6347         +x(60)*xx*yy*zz
6348       dsc_i   = 0.743d0+x(61)
6349       dp2_i   = 1.9d0+x(62)
6350       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6351                 *(xx*cost2+yy*sint2))
6352       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6353                 *(xx*cost2-yy*sint2))
6354       s1=(1+x(63))/(0.1d0 + dscp1)
6355       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6356       s2=(1+x(65))/(0.1d0 + dscp2)
6357       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6358       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6359        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6360       enesc=sumene
6361       return
6362       end function enesc
6363 #endif
6364 !-----------------------------------------------------------------------------
6365       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6366 !
6367 ! This procedure calculates two-body contact function g(rij) and its derivative:
6368 !
6369 !           eps0ij                                     !       x < -1
6370 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6371 !            0                                         !       x > 1
6372 !
6373 ! where x=(rij-r0ij)/delta
6374 !
6375 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6376 !
6377 !      implicit none
6378       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6379       real(kind=8) :: x,x2,x4,delta
6380 !     delta=0.02D0*r0ij
6381 !      delta=0.2D0*r0ij
6382       x=(rij-r0ij)/delta
6383       if (x.lt.-1.0D0) then
6384         fcont=eps0ij
6385         fprimcont=0.0D0
6386       else if (x.le.1.0D0) then
6387         x2=x*x
6388         x4=x2*x2
6389         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6390         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6391       else
6392         fcont=0.0D0
6393         fprimcont=0.0D0
6394       endif
6395       return
6396       end subroutine gcont
6397 !-----------------------------------------------------------------------------
6398       subroutine splinthet(theti,delta,ss,ssder)
6399 !      implicit real*8 (a-h,o-z)
6400 !      include 'DIMENSIONS'
6401 !      include 'COMMON.VAR'
6402 !      include 'COMMON.GEO'
6403       real(kind=8) :: theti,delta,ss,ssder
6404       real(kind=8) :: thetup,thetlow
6405       thetup=pi-delta
6406       thetlow=delta
6407       if (theti.gt.pipol) then
6408         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6409       else
6410         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6411         ssder=-ssder
6412       endif
6413       return
6414       end subroutine splinthet
6415 !-----------------------------------------------------------------------------
6416       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6417 !      implicit none
6418       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6419       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6420       a1=fprim0*delta/(f1-f0)
6421       a2=3.0d0-2.0d0*a1
6422       a3=a1-2.0d0
6423       ksi=(x-x0)/delta
6424       ksi2=ksi*ksi
6425       ksi3=ksi2*ksi
6426       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6427       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6428       return
6429       end subroutine spline1
6430 !-----------------------------------------------------------------------------
6431       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6432 !      implicit none
6433       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6434       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6435       ksi=(x-x0)/delta
6436       ksi2=ksi*ksi
6437       ksi3=ksi2*ksi
6438       a1=fprim0x*delta
6439       a2=3*(f1x-f0x)-2*fprim0x*delta
6440       a3=fprim0x*delta-2*(f1x-f0x)
6441       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6442       return
6443       end subroutine spline2
6444 !-----------------------------------------------------------------------------
6445 #ifdef CRYST_TOR
6446 !-----------------------------------------------------------------------------
6447       subroutine etor(etors,edihcnstr)
6448 !      implicit real*8 (a-h,o-z)
6449 !      include 'DIMENSIONS'
6450 !      include 'COMMON.VAR'
6451 !      include 'COMMON.GEO'
6452 !      include 'COMMON.LOCAL'
6453 !      include 'COMMON.TORSION'
6454 !      include 'COMMON.INTERACT'
6455 !      include 'COMMON.DERIV'
6456 !      include 'COMMON.CHAIN'
6457 !      include 'COMMON.NAMES'
6458 !      include 'COMMON.IOUNITS'
6459 !      include 'COMMON.FFIELD'
6460 !      include 'COMMON.TORCNSTR'
6461 !      include 'COMMON.CONTROL'
6462       real(kind=8) :: etors,edihcnstr
6463       logical :: lprn
6464 !el local variables
6465       integer :: i,j,
6466       real(kind=8) :: phii,fac,etors_ii
6467
6468 ! Set lprn=.true. for debugging
6469       lprn=.false.
6470 !      lprn=.true.
6471       etors=0.0D0
6472       do i=iphi_start,iphi_end
6473       etors_ii=0.0D0
6474         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 &
6475             .or. itype(i).eq.ntyp1) cycle
6476         itori=itortyp(itype(i-2))
6477         itori1=itortyp(itype(i-1))
6478         phii=phi(i)
6479         gloci=0.0D0
6480 ! Proline-Proline pair is a special case...
6481         if (itori.eq.3 .and. itori1.eq.3) then
6482           if (phii.gt.-dwapi3) then
6483             cosphi=dcos(3*phii)
6484             fac=1.0D0/(1.0D0-cosphi)
6485             etorsi=v1(1,3,3)*fac
6486             etorsi=etorsi+etorsi
6487             etors=etors+etorsi-v1(1,3,3)
6488             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6489             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6490           endif
6491           do j=1,3
6492             v1ij=v1(j+1,itori,itori1)
6493             v2ij=v2(j+1,itori,itori1)
6494             cosphi=dcos(j*phii)
6495             sinphi=dsin(j*phii)
6496             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6497             if (energy_dec) etors_ii=etors_ii+ &
6498                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6499             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6500           enddo
6501         else
6502           do j=1,nterm_old
6503             v1ij=v1(j,itori,itori1)
6504             v2ij=v2(j,itori,itori1)
6505             cosphi=dcos(j*phii)
6506             sinphi=dsin(j*phii)
6507             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6508             if (energy_dec) etors_ii=etors_ii+ &
6509                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6510             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6511           enddo
6512         endif
6513         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6514              'etor',i,etors_ii
6515         if (lprn) &
6516         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6517         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
6518         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6519         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6520 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6521       enddo
6522 ! 6/20/98 - dihedral angle constraints
6523       edihcnstr=0.0d0
6524       do i=1,ndih_constr
6525         itori=idih_constr(i)
6526         phii=phi(itori)
6527         difi=phii-phi0(i)
6528         if (difi.gt.drange(i)) then
6529           difi=difi-drange(i)
6530           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6531           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6532         else if (difi.lt.-drange(i)) then
6533           difi=difi+drange(i)
6534           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6535           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6536         endif
6537 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6538 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6539       enddo
6540 !      write (iout,*) 'edihcnstr',edihcnstr
6541       return
6542       end subroutine etor
6543 !-----------------------------------------------------------------------------
6544       subroutine etor_d(etors_d)
6545       real(kind=8) :: etors_d
6546       etors_d=0.0d0
6547       return
6548       end subroutine etor_d
6549 #else
6550 !-----------------------------------------------------------------------------
6551       subroutine etor(etors,edihcnstr)
6552 !      implicit real*8 (a-h,o-z)
6553 !      include 'DIMENSIONS'
6554 !      include 'COMMON.VAR'
6555 !      include 'COMMON.GEO'
6556 !      include 'COMMON.LOCAL'
6557 !      include 'COMMON.TORSION'
6558 !      include 'COMMON.INTERACT'
6559 !      include 'COMMON.DERIV'
6560 !      include 'COMMON.CHAIN'
6561 !      include 'COMMON.NAMES'
6562 !      include 'COMMON.IOUNITS'
6563 !      include 'COMMON.FFIELD'
6564 !      include 'COMMON.TORCNSTR'
6565 !      include 'COMMON.CONTROL'
6566       real(kind=8) :: etors,edihcnstr
6567       logical :: lprn
6568 !el local variables
6569       integer :: i,j,iblock,itori,itori1
6570       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6571                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6572 ! Set lprn=.true. for debugging
6573       lprn=.false.
6574 !     lprn=.true.
6575       etors=0.0D0
6576       do i=iphi_start,iphi_end
6577         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
6578              .or. itype(i-3).eq.ntyp1 &
6579              .or. itype(i).eq.ntyp1) cycle
6580         etors_ii=0.0D0
6581          if (iabs(itype(i)).eq.20) then
6582          iblock=2
6583          else
6584          iblock=1
6585          endif
6586         itori=itortyp(itype(i-2))
6587         itori1=itortyp(itype(i-1))
6588         phii=phi(i)
6589         gloci=0.0D0
6590 ! Regular cosine and sine terms
6591         do j=1,nterm(itori,itori1,iblock)
6592           v1ij=v1(j,itori,itori1,iblock)
6593           v2ij=v2(j,itori,itori1,iblock)
6594           cosphi=dcos(j*phii)
6595           sinphi=dsin(j*phii)
6596           etors=etors+v1ij*cosphi+v2ij*sinphi
6597           if (energy_dec) etors_ii=etors_ii+ &
6598                      v1ij*cosphi+v2ij*sinphi
6599           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6600         enddo
6601 ! Lorentz terms
6602 !                         v1
6603 !  E = SUM ----------------------------------- - v1
6604 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6605 !
6606         cosphi=dcos(0.5d0*phii)
6607         sinphi=dsin(0.5d0*phii)
6608         do j=1,nlor(itori,itori1,iblock)
6609           vl1ij=vlor1(j,itori,itori1)
6610           vl2ij=vlor2(j,itori,itori1)
6611           vl3ij=vlor3(j,itori,itori1)
6612           pom=vl2ij*cosphi+vl3ij*sinphi
6613           pom1=1.0d0/(pom*pom+1.0d0)
6614           etors=etors+vl1ij*pom1
6615           if (energy_dec) etors_ii=etors_ii+ &
6616                      vl1ij*pom1
6617           pom=-pom*pom1*pom1
6618           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6619         enddo
6620 ! Subtract the constant term
6621         etors=etors-v0(itori,itori1,iblock)
6622           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6623                'etor',i,etors_ii-v0(itori,itori1,iblock)
6624         if (lprn) &
6625         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6626         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
6627         (v1(j,itori,itori1,iblock),j=1,6),&
6628         (v2(j,itori,itori1,iblock),j=1,6)
6629         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6630 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6631       enddo
6632 ! 6/20/98 - dihedral angle constraints
6633       edihcnstr=0.0d0
6634 !      do i=1,ndih_constr
6635       do i=idihconstr_start,idihconstr_end
6636         itori=idih_constr(i)
6637         phii=phi(itori)
6638         difi=pinorm(phii-phi0(i))
6639         if (difi.gt.drange(i)) then
6640           difi=difi-drange(i)
6641           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6642           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6643         else if (difi.lt.-drange(i)) then
6644           difi=difi+drange(i)
6645           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6646           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6647         else
6648           difi=0.0
6649         endif
6650 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6651 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6652 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6653       enddo
6654 !d       write (iout,*) 'edihcnstr',edihcnstr
6655       return
6656       end subroutine etor
6657 !-----------------------------------------------------------------------------
6658       subroutine etor_d(etors_d)
6659 ! 6/23/01 Compute double torsional energy
6660 !      implicit real*8 (a-h,o-z)
6661 !      include 'DIMENSIONS'
6662 !      include 'COMMON.VAR'
6663 !      include 'COMMON.GEO'
6664 !      include 'COMMON.LOCAL'
6665 !      include 'COMMON.TORSION'
6666 !      include 'COMMON.INTERACT'
6667 !      include 'COMMON.DERIV'
6668 !      include 'COMMON.CHAIN'
6669 !      include 'COMMON.NAMES'
6670 !      include 'COMMON.IOUNITS'
6671 !      include 'COMMON.FFIELD'
6672 !      include 'COMMON.TORCNSTR'
6673       real(kind=8) :: etors_d,etors_d_ii
6674       logical :: lprn
6675 !el local variables
6676       integer :: i,j,k,l,itori,itori1,itori2,iblock
6677       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6678                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6679                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6680                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6681 ! Set lprn=.true. for debugging
6682       lprn=.false.
6683 !     lprn=.true.
6684       etors_d=0.0D0
6685 !      write(iout,*) "a tu??"
6686       do i=iphid_start,iphid_end
6687         etors_d_ii=0.0D0
6688         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
6689             .or. itype(i-3).eq.ntyp1 &
6690             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
6691         itori=itortyp(itype(i-2))
6692         itori1=itortyp(itype(i-1))
6693         itori2=itortyp(itype(i))
6694         phii=phi(i)
6695         phii1=phi(i+1)
6696         gloci1=0.0D0
6697         gloci2=0.0D0
6698         iblock=1
6699         if (iabs(itype(i+1)).eq.20) iblock=2
6700
6701 ! Regular cosine and sine terms
6702         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6703           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6704           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6705           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6706           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6707           cosphi1=dcos(j*phii)
6708           sinphi1=dsin(j*phii)
6709           cosphi2=dcos(j*phii1)
6710           sinphi2=dsin(j*phii1)
6711           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6712            v2cij*cosphi2+v2sij*sinphi2
6713           if (energy_dec) etors_d_ii=etors_d_ii+ &
6714            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6715           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6716           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6717         enddo
6718         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6719           do l=1,k-1
6720             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6721             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6722             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6723             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6724             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6725             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6726             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6727             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6728             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6729               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6730             if (energy_dec) etors_d_ii=etors_d_ii+ &
6731               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6732               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6733             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6734               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6735             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6736               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6737           enddo
6738         enddo
6739         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6740                             'etor_d',i,etors_d_ii
6741         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6742         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6743       enddo
6744       return
6745       end subroutine etor_d
6746 #endif
6747 !-----------------------------------------------------------------------------
6748       subroutine eback_sc_corr(esccor)
6749 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
6750 !        conformational states; temporarily implemented as differences
6751 !        between UNRES torsional potentials (dependent on three types of
6752 !        residues) and the torsional potentials dependent on all 20 types
6753 !        of residues computed from AM1  energy surfaces of terminally-blocked
6754 !        amino-acid residues.
6755 !      implicit real*8 (a-h,o-z)
6756 !      include 'DIMENSIONS'
6757 !      include 'COMMON.VAR'
6758 !      include 'COMMON.GEO'
6759 !      include 'COMMON.LOCAL'
6760 !      include 'COMMON.TORSION'
6761 !      include 'COMMON.SCCOR'
6762 !      include 'COMMON.INTERACT'
6763 !      include 'COMMON.DERIV'
6764 !      include 'COMMON.CHAIN'
6765 !      include 'COMMON.NAMES'
6766 !      include 'COMMON.IOUNITS'
6767 !      include 'COMMON.FFIELD'
6768 !      include 'COMMON.CONTROL'
6769       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
6770                    cosphi,sinphi
6771       logical :: lprn
6772       integer :: i,interty,j,isccori,isccori1,intertyp
6773 ! Set lprn=.true. for debugging
6774       lprn=.false.
6775 !      lprn=.true.
6776 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6777       esccor=0.0D0
6778       do i=itau_start,itau_end
6779         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6780         esccor_ii=0.0D0
6781         isccori=isccortyp(itype(i-2))
6782         isccori1=isccortyp(itype(i-1))
6783
6784 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6785         phii=phi(i)
6786         do intertyp=1,3 !intertyp
6787          esccor_ii=0.0D0
6788 !c Added 09 May 2012 (Adasko)
6789 !c  Intertyp means interaction type of backbone mainchain correlation:
6790 !   1 = SC...Ca...Ca...Ca
6791 !   2 = Ca...Ca...Ca...SC
6792 !   3 = SC...Ca...Ca...SCi
6793         gloci=0.0D0
6794         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
6795             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
6796             (itype(i-1).eq.ntyp1))) &
6797           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
6798            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
6799            .or.(itype(i).eq.ntyp1))) &
6800           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
6801             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
6802             (itype(i-3).eq.ntyp1)))) cycle
6803         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6804         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
6805        cycle
6806        do j=1,nterm_sccor(isccori,isccori1)
6807           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6808           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6809           cosphi=dcos(j*tauangle(intertyp,i))
6810           sinphi=dsin(j*tauangle(intertyp,i))
6811           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6812           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6813           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6814         enddo
6815         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
6816                                 'esccor',i,intertyp,esccor_ii
6817 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6818         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6819         if (lprn) &
6820         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6821         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
6822         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
6823         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6824         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6825        enddo !intertyp
6826       enddo
6827
6828       return
6829       end subroutine eback_sc_corr
6830 !-----------------------------------------------------------------------------
6831       subroutine multibody(ecorr)
6832 ! This subroutine calculates multi-body contributions to energy following
6833 ! the idea of Skolnick et al. If side chains I and J make a contact and
6834 ! at the same time side chains I+1 and J+1 make a contact, an extra
6835 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6836 !      implicit real*8 (a-h,o-z)
6837 !      include 'DIMENSIONS'
6838 !      include 'COMMON.IOUNITS'
6839 !      include 'COMMON.DERIV'
6840 !      include 'COMMON.INTERACT'
6841 !      include 'COMMON.CONTACTS'
6842       real(kind=8),dimension(3) :: gx,gx1
6843       logical :: lprn
6844       real(kind=8) :: ecorr
6845       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
6846 ! Set lprn=.true. for debugging
6847       lprn=.false.
6848
6849       if (lprn) then
6850         write (iout,'(a)') 'Contact function values:'
6851         do i=nnt,nct-2
6852           write (iout,'(i2,20(1x,i2,f10.5))') &
6853               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6854         enddo
6855       endif
6856       ecorr=0.0D0
6857
6858 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6859 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6860       do i=nnt,nct
6861         do j=1,3
6862           gradcorr(j,i)=0.0D0
6863           gradxorr(j,i)=0.0D0
6864         enddo
6865       enddo
6866       do i=nnt,nct-2
6867
6868         DO ISHIFT = 3,4
6869
6870         i1=i+ishift
6871         num_conti=num_cont(i)
6872         num_conti1=num_cont(i1)
6873         do jj=1,num_conti
6874           j=jcont(jj,i)
6875           do kk=1,num_conti1
6876             j1=jcont(kk,i1)
6877             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6878 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6879 !d   &                   ' ishift=',ishift
6880 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6881 ! The system gains extra energy.
6882               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6883             endif   ! j1==j+-ishift
6884           enddo     ! kk
6885         enddo       ! jj
6886
6887         ENDDO ! ISHIFT
6888
6889       enddo         ! i
6890       return
6891       end subroutine multibody
6892 !-----------------------------------------------------------------------------
6893       real(kind=8) function esccorr(i,j,k,l,jj,kk)
6894 !      implicit real*8 (a-h,o-z)
6895 !      include 'DIMENSIONS'
6896 !      include 'COMMON.IOUNITS'
6897 !      include 'COMMON.DERIV'
6898 !      include 'COMMON.INTERACT'
6899 !      include 'COMMON.CONTACTS'
6900       real(kind=8),dimension(3) :: gx,gx1
6901       logical :: lprn
6902       integer :: i,j,k,l,jj,kk,m,ll
6903       real(kind=8) :: eij,ekl
6904       lprn=.false.
6905       eij=facont(jj,i)
6906       ekl=facont(kk,k)
6907 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6908 ! Calculate the multi-body contribution to energy.
6909 ! Calculate multi-body contributions to the gradient.
6910 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6911 !d   & k,l,(gacont(m,kk,k),m=1,3)
6912       do m=1,3
6913         gx(m) =ekl*gacont(m,jj,i)
6914         gx1(m)=eij*gacont(m,kk,k)
6915         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6916         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6917         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6918         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6919       enddo
6920       do m=i,j-1
6921         do ll=1,3
6922           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6923         enddo
6924       enddo
6925       do m=k,l-1
6926         do ll=1,3
6927           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6928         enddo
6929       enddo
6930       esccorr=-eij*ekl
6931       return
6932       end function esccorr
6933 !-----------------------------------------------------------------------------
6934       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6935 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6936 !      implicit real*8 (a-h,o-z)
6937 !      include 'DIMENSIONS'
6938 !      include 'COMMON.IOUNITS'
6939 #ifdef MPI
6940       include "mpif.h"
6941 !      integer :: maxconts !max_cont=maxconts  =nres/4
6942       integer,parameter :: max_dim=26
6943       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6944       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6945 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6946 !el      common /przechowalnia/ zapas
6947       integer :: status(MPI_STATUS_SIZE)
6948       integer,dimension((nres/4)*2) :: req !maxconts*2
6949       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
6950 #endif
6951 !      include 'COMMON.SETUP'
6952 !      include 'COMMON.FFIELD'
6953 !      include 'COMMON.DERIV'
6954 !      include 'COMMON.INTERACT'
6955 !      include 'COMMON.CONTACTS'
6956 !      include 'COMMON.CONTROL'
6957 !      include 'COMMON.LOCAL'
6958       real(kind=8),dimension(3) :: gx,gx1
6959       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
6960       logical :: lprn,ldone
6961 !el local variables
6962       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
6963               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
6964
6965 ! Set lprn=.true. for debugging
6966       lprn=.false.
6967 #ifdef MPI
6968 !      maxconts=nres/4
6969       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6970       n_corr=0
6971       n_corr1=0
6972       if (nfgtasks.le.1) goto 30
6973       if (lprn) then
6974         write (iout,'(a)') 'Contact function values before RECEIVE:'
6975         do i=nnt,nct-2
6976           write (iout,'(2i3,50(1x,i2,f5.2))') &
6977           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6978           j=1,num_cont_hb(i))
6979         enddo
6980       endif
6981       call flush(iout)
6982       do i=1,ntask_cont_from
6983         ncont_recv(i)=0
6984       enddo
6985       do i=1,ntask_cont_to
6986         ncont_sent(i)=0
6987       enddo
6988 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6989 !     & ntask_cont_to
6990 ! Make the list of contacts to send to send to other procesors
6991 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6992 !      call flush(iout)
6993       do i=iturn3_start,iturn3_end
6994 !        write (iout,*) "make contact list turn3",i," num_cont",
6995 !     &    num_cont_hb(i)
6996         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6997       enddo
6998       do i=iturn4_start,iturn4_end
6999 !        write (iout,*) "make contact list turn4",i," num_cont",
7000 !     &   num_cont_hb(i)
7001         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7002       enddo
7003       do ii=1,nat_sent
7004         i=iat_sent(ii)
7005 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7006 !     &    num_cont_hb(i)
7007         do j=1,num_cont_hb(i)
7008         do k=1,4
7009           jjc=jcont_hb(j,i)
7010           iproc=iint_sent_local(k,jjc,ii)
7011 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7012           if (iproc.gt.0) then
7013             ncont_sent(iproc)=ncont_sent(iproc)+1
7014             nn=ncont_sent(iproc)
7015             zapas(1,nn,iproc)=i
7016             zapas(2,nn,iproc)=jjc
7017             zapas(3,nn,iproc)=facont_hb(j,i)
7018             zapas(4,nn,iproc)=ees0p(j,i)
7019             zapas(5,nn,iproc)=ees0m(j,i)
7020             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7021             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7022             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7023             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7024             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7025             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7026             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7027             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7028             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7029             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7030             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7031             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7032             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7033             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7034             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7035             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7036             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7037             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7038             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7039             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7040             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7041           endif
7042         enddo
7043         enddo
7044       enddo
7045       if (lprn) then
7046       write (iout,*) &
7047         "Numbers of contacts to be sent to other processors",&
7048         (ncont_sent(i),i=1,ntask_cont_to)
7049       write (iout,*) "Contacts sent"
7050       do ii=1,ntask_cont_to
7051         nn=ncont_sent(ii)
7052         iproc=itask_cont_to(ii)
7053         write (iout,*) nn," contacts to processor",iproc,&
7054          " of CONT_TO_COMM group"
7055         do i=1,nn
7056           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7057         enddo
7058       enddo
7059       call flush(iout)
7060       endif
7061       CorrelType=477
7062       CorrelID=fg_rank+1
7063       CorrelType1=478
7064       CorrelID1=nfgtasks+fg_rank+1
7065       ireq=0
7066 ! Receive the numbers of needed contacts from other processors
7067       do ii=1,ntask_cont_from
7068         iproc=itask_cont_from(ii)
7069         ireq=ireq+1
7070         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7071           FG_COMM,req(ireq),IERR)
7072       enddo
7073 !      write (iout,*) "IRECV ended"
7074 !      call flush(iout)
7075 ! Send the number of contacts needed by other processors
7076       do ii=1,ntask_cont_to
7077         iproc=itask_cont_to(ii)
7078         ireq=ireq+1
7079         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7080           FG_COMM,req(ireq),IERR)
7081       enddo
7082 !      write (iout,*) "ISEND ended"
7083 !      write (iout,*) "number of requests (nn)",ireq
7084       call flush(iout)
7085       if (ireq.gt.0) &
7086         call MPI_Waitall(ireq,req,status_array,ierr)
7087 !      write (iout,*)
7088 !     &  "Numbers of contacts to be received from other processors",
7089 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7090 !      call flush(iout)
7091 ! Receive contacts
7092       ireq=0
7093       do ii=1,ntask_cont_from
7094         iproc=itask_cont_from(ii)
7095         nn=ncont_recv(ii)
7096 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7097 !     &   " of CONT_TO_COMM group"
7098         call flush(iout)
7099         if (nn.gt.0) then
7100           ireq=ireq+1
7101           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7102           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7103 !          write (iout,*) "ireq,req",ireq,req(ireq)
7104         endif
7105       enddo
7106 ! Send the contacts to processors that need them
7107       do ii=1,ntask_cont_to
7108         iproc=itask_cont_to(ii)
7109         nn=ncont_sent(ii)
7110 !        write (iout,*) nn," contacts to processor",iproc,
7111 !     &   " of CONT_TO_COMM group"
7112         if (nn.gt.0) then
7113           ireq=ireq+1
7114           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7115             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7116 !          write (iout,*) "ireq,req",ireq,req(ireq)
7117 !          do i=1,nn
7118 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7119 !          enddo
7120         endif
7121       enddo
7122 !      write (iout,*) "number of requests (contacts)",ireq
7123 !      write (iout,*) "req",(req(i),i=1,4)
7124 !      call flush(iout)
7125       if (ireq.gt.0) &
7126        call MPI_Waitall(ireq,req,status_array,ierr)
7127       do iii=1,ntask_cont_from
7128         iproc=itask_cont_from(iii)
7129         nn=ncont_recv(iii)
7130         if (lprn) then
7131         write (iout,*) "Received",nn," contacts from processor",iproc,&
7132          " of CONT_FROM_COMM group"
7133         call flush(iout)
7134         do i=1,nn
7135           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7136         enddo
7137         call flush(iout)
7138         endif
7139         do i=1,nn
7140           ii=zapas_recv(1,i,iii)
7141 ! Flag the received contacts to prevent double-counting
7142           jj=-zapas_recv(2,i,iii)
7143 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7144 !          call flush(iout)
7145           nnn=num_cont_hb(ii)+1
7146           num_cont_hb(ii)=nnn
7147           jcont_hb(nnn,ii)=jj
7148           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7149           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7150           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7151           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7152           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7153           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7154           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7155           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7156           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7157           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7158           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7159           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7160           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7161           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7162           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7163           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7164           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7165           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7166           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7167           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7168           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7169           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7170           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7171           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7172         enddo
7173       enddo
7174       call flush(iout)
7175       if (lprn) then
7176         write (iout,'(a)') 'Contact function values after receive:'
7177         do i=nnt,nct-2
7178           write (iout,'(2i3,50(1x,i3,f5.2))') &
7179           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7180           j=1,num_cont_hb(i))
7181         enddo
7182         call flush(iout)
7183       endif
7184    30 continue
7185 #endif
7186       if (lprn) then
7187         write (iout,'(a)') 'Contact function values:'
7188         do i=nnt,nct-2
7189           write (iout,'(2i3,50(1x,i3,f5.2))') &
7190           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7191           j=1,num_cont_hb(i))
7192         enddo
7193       endif
7194       ecorr=0.0D0
7195
7196 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7197 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7198 ! Remove the loop below after debugging !!!
7199       do i=nnt,nct
7200         do j=1,3
7201           gradcorr(j,i)=0.0D0
7202           gradxorr(j,i)=0.0D0
7203         enddo
7204       enddo
7205 ! Calculate the local-electrostatic correlation terms
7206       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7207         i1=i+1
7208         num_conti=num_cont_hb(i)
7209         num_conti1=num_cont_hb(i+1)
7210         do jj=1,num_conti
7211           j=jcont_hb(jj,i)
7212           jp=iabs(j)
7213           do kk=1,num_conti1
7214             j1=jcont_hb(kk,i1)
7215             jp1=iabs(j1)
7216 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7217 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7218             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7219                 .or. j.lt.0 .and. j1.gt.0) .and. &
7220                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7221 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7222 ! The system gains extra energy.
7223               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7224               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7225                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7226               n_corr=n_corr+1
7227             else if (j1.eq.j) then
7228 ! Contacts I-J and I-(J+1) occur simultaneously.
7229 ! The system loses extra energy.
7230 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7231             endif
7232           enddo ! kk
7233           do kk=1,num_conti
7234             j1=jcont_hb(kk,i)
7235 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7236 !    &         ' jj=',jj,' kk=',kk
7237             if (j1.eq.j+1) then
7238 ! Contacts I-J and (I+1)-J occur simultaneously.
7239 ! The system loses extra energy.
7240 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7241             endif ! j1==j+1
7242           enddo ! kk
7243         enddo ! jj
7244       enddo ! i
7245       return
7246       end subroutine multibody_hb
7247 !-----------------------------------------------------------------------------
7248       subroutine add_hb_contact(ii,jj,itask)
7249 !      implicit real*8 (a-h,o-z)
7250 !      include "DIMENSIONS"
7251 !      include "COMMON.IOUNITS"
7252 !      include "COMMON.CONTACTS"
7253 !      integer,parameter :: maxconts=nres/4
7254       integer,parameter :: max_dim=26
7255       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7256 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7257 !      common /przechowalnia/ zapas
7258       integer :: i,j,ii,jj,iproc,nn,jjc
7259       integer,dimension(4) :: itask
7260 !      write (iout,*) "itask",itask
7261       do i=1,2
7262         iproc=itask(i)
7263         if (iproc.gt.0) then
7264           do j=1,num_cont_hb(ii)
7265             jjc=jcont_hb(j,ii)
7266 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7267             if (jjc.eq.jj) then
7268               ncont_sent(iproc)=ncont_sent(iproc)+1
7269               nn=ncont_sent(iproc)
7270               zapas(1,nn,iproc)=ii
7271               zapas(2,nn,iproc)=jjc
7272               zapas(3,nn,iproc)=facont_hb(j,ii)
7273               zapas(4,nn,iproc)=ees0p(j,ii)
7274               zapas(5,nn,iproc)=ees0m(j,ii)
7275               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7276               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7277               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7278               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7279               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7280               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7281               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7282               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7283               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7284               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7285               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7286               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7287               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7288               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7289               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7290               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7291               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7292               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7293               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7294               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7295               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7296               exit
7297             endif
7298           enddo
7299         endif
7300       enddo
7301       return
7302       end subroutine add_hb_contact
7303 !-----------------------------------------------------------------------------
7304       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7305 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7306 !      implicit real*8 (a-h,o-z)
7307 !      include 'DIMENSIONS'
7308 !      include 'COMMON.IOUNITS'
7309       integer,parameter :: max_dim=70
7310 #ifdef MPI
7311       include "mpif.h"
7312 !      integer :: maxconts !max_cont=maxconts=nres/4
7313       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7314       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7315 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7316 !      common /przechowalnia/ zapas
7317       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7318         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7319         ierr,iii,nnn
7320 #endif
7321 !      include 'COMMON.SETUP'
7322 !      include 'COMMON.FFIELD'
7323 !      include 'COMMON.DERIV'
7324 !      include 'COMMON.LOCAL'
7325 !      include 'COMMON.INTERACT'
7326 !      include 'COMMON.CONTACTS'
7327 !      include 'COMMON.CHAIN'
7328 !      include 'COMMON.CONTROL'
7329       real(kind=8),dimension(3) :: gx,gx1
7330       integer,dimension(nres) :: num_cont_hb_old
7331       logical :: lprn,ldone
7332 !EL      double precision eello4,eello5,eelo6,eello_turn6
7333 !EL      external eello4,eello5,eello6,eello_turn6
7334 !el local variables
7335       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7336               j1,jp1,i1,num_conti1
7337       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7338       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7339
7340 ! Set lprn=.true. for debugging
7341       lprn=.false.
7342       eturn6=0.0d0
7343 #ifdef MPI
7344 !      maxconts=nres/4
7345       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7346       do i=1,nres
7347         num_cont_hb_old(i)=num_cont_hb(i)
7348       enddo
7349       n_corr=0
7350       n_corr1=0
7351       if (nfgtasks.le.1) goto 30
7352       if (lprn) then
7353         write (iout,'(a)') 'Contact function values before RECEIVE:'
7354         do i=nnt,nct-2
7355           write (iout,'(2i3,50(1x,i2,f5.2))') &
7356           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7357           j=1,num_cont_hb(i))
7358         enddo
7359       endif
7360       call flush(iout)
7361       do i=1,ntask_cont_from
7362         ncont_recv(i)=0
7363       enddo
7364       do i=1,ntask_cont_to
7365         ncont_sent(i)=0
7366       enddo
7367 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7368 !     & ntask_cont_to
7369 ! Make the list of contacts to send to send to other procesors
7370       do i=iturn3_start,iturn3_end
7371 !        write (iout,*) "make contact list turn3",i," num_cont",
7372 !     &    num_cont_hb(i)
7373         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7374       enddo
7375       do i=iturn4_start,iturn4_end
7376 !        write (iout,*) "make contact list turn4",i," num_cont",
7377 !     &   num_cont_hb(i)
7378         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7379       enddo
7380       do ii=1,nat_sent
7381         i=iat_sent(ii)
7382 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7383 !     &    num_cont_hb(i)
7384         do j=1,num_cont_hb(i)
7385         do k=1,4
7386           jjc=jcont_hb(j,i)
7387           iproc=iint_sent_local(k,jjc,ii)
7388 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7389           if (iproc.ne.0) then
7390             ncont_sent(iproc)=ncont_sent(iproc)+1
7391             nn=ncont_sent(iproc)
7392             zapas(1,nn,iproc)=i
7393             zapas(2,nn,iproc)=jjc
7394             zapas(3,nn,iproc)=d_cont(j,i)
7395             ind=3
7396             do kk=1,3
7397               ind=ind+1
7398               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7399             enddo
7400             do kk=1,2
7401               do ll=1,2
7402                 ind=ind+1
7403                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7404               enddo
7405             enddo
7406             do jj=1,5
7407               do kk=1,3
7408                 do ll=1,2
7409                   do mm=1,2
7410                     ind=ind+1
7411                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7412                   enddo
7413                 enddo
7414               enddo
7415             enddo
7416           endif
7417         enddo
7418         enddo
7419       enddo
7420       if (lprn) then
7421       write (iout,*) &
7422         "Numbers of contacts to be sent to other processors",&
7423         (ncont_sent(i),i=1,ntask_cont_to)
7424       write (iout,*) "Contacts sent"
7425       do ii=1,ntask_cont_to
7426         nn=ncont_sent(ii)
7427         iproc=itask_cont_to(ii)
7428         write (iout,*) nn," contacts to processor",iproc,&
7429          " of CONT_TO_COMM group"
7430         do i=1,nn
7431           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7432         enddo
7433       enddo
7434       call flush(iout)
7435       endif
7436       CorrelType=477
7437       CorrelID=fg_rank+1
7438       CorrelType1=478
7439       CorrelID1=nfgtasks+fg_rank+1
7440       ireq=0
7441 ! Receive the numbers of needed contacts from other processors
7442       do ii=1,ntask_cont_from
7443         iproc=itask_cont_from(ii)
7444         ireq=ireq+1
7445         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7446           FG_COMM,req(ireq),IERR)
7447       enddo
7448 !      write (iout,*) "IRECV ended"
7449 !      call flush(iout)
7450 ! Send the number of contacts needed by other processors
7451       do ii=1,ntask_cont_to
7452         iproc=itask_cont_to(ii)
7453         ireq=ireq+1
7454         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7455           FG_COMM,req(ireq),IERR)
7456       enddo
7457 !      write (iout,*) "ISEND ended"
7458 !      write (iout,*) "number of requests (nn)",ireq
7459       call flush(iout)
7460       if (ireq.gt.0) &
7461         call MPI_Waitall(ireq,req,status_array,ierr)
7462 !      write (iout,*)
7463 !     &  "Numbers of contacts to be received from other processors",
7464 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7465 !      call flush(iout)
7466 ! Receive contacts
7467       ireq=0
7468       do ii=1,ntask_cont_from
7469         iproc=itask_cont_from(ii)
7470         nn=ncont_recv(ii)
7471 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7472 !     &   " of CONT_TO_COMM group"
7473         call flush(iout)
7474         if (nn.gt.0) then
7475           ireq=ireq+1
7476           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7477           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7478 !          write (iout,*) "ireq,req",ireq,req(ireq)
7479         endif
7480       enddo
7481 ! Send the contacts to processors that need them
7482       do ii=1,ntask_cont_to
7483         iproc=itask_cont_to(ii)
7484         nn=ncont_sent(ii)
7485 !        write (iout,*) nn," contacts to processor",iproc,
7486 !     &   " of CONT_TO_COMM group"
7487         if (nn.gt.0) then
7488           ireq=ireq+1
7489           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7490             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7491 !          write (iout,*) "ireq,req",ireq,req(ireq)
7492 !          do i=1,nn
7493 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7494 !          enddo
7495         endif
7496       enddo
7497 !      write (iout,*) "number of requests (contacts)",ireq
7498 !      write (iout,*) "req",(req(i),i=1,4)
7499 !      call flush(iout)
7500       if (ireq.gt.0) &
7501        call MPI_Waitall(ireq,req,status_array,ierr)
7502       do iii=1,ntask_cont_from
7503         iproc=itask_cont_from(iii)
7504         nn=ncont_recv(iii)
7505         if (lprn) then
7506         write (iout,*) "Received",nn," contacts from processor",iproc,&
7507          " of CONT_FROM_COMM group"
7508         call flush(iout)
7509         do i=1,nn
7510           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7511         enddo
7512         call flush(iout)
7513         endif
7514         do i=1,nn
7515           ii=zapas_recv(1,i,iii)
7516 ! Flag the received contacts to prevent double-counting
7517           jj=-zapas_recv(2,i,iii)
7518 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7519 !          call flush(iout)
7520           nnn=num_cont_hb(ii)+1
7521           num_cont_hb(ii)=nnn
7522           jcont_hb(nnn,ii)=jj
7523           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7524           ind=3
7525           do kk=1,3
7526             ind=ind+1
7527             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7528           enddo
7529           do kk=1,2
7530             do ll=1,2
7531               ind=ind+1
7532               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7533             enddo
7534           enddo
7535           do jj=1,5
7536             do kk=1,3
7537               do ll=1,2
7538                 do mm=1,2
7539                   ind=ind+1
7540                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7541                 enddo
7542               enddo
7543             enddo
7544           enddo
7545         enddo
7546       enddo
7547       call flush(iout)
7548       if (lprn) then
7549         write (iout,'(a)') 'Contact function values after receive:'
7550         do i=nnt,nct-2
7551           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7552           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7553           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7554         enddo
7555         call flush(iout)
7556       endif
7557    30 continue
7558 #endif
7559       if (lprn) then
7560         write (iout,'(a)') 'Contact function values:'
7561         do i=nnt,nct-2
7562           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7563           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7564           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7565         enddo
7566       endif
7567       ecorr=0.0D0
7568       ecorr5=0.0d0
7569       ecorr6=0.0d0
7570
7571 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7572 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7573 ! Remove the loop below after debugging !!!
7574       do i=nnt,nct
7575         do j=1,3
7576           gradcorr(j,i)=0.0D0
7577           gradxorr(j,i)=0.0D0
7578         enddo
7579       enddo
7580 ! Calculate the dipole-dipole interaction energies
7581       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7582       do i=iatel_s,iatel_e+1
7583         num_conti=num_cont_hb(i)
7584         do jj=1,num_conti
7585           j=jcont_hb(jj,i)
7586 #ifdef MOMENT
7587           call dipole(i,j,jj)
7588 #endif
7589         enddo
7590       enddo
7591       endif
7592 ! Calculate the local-electrostatic correlation terms
7593 !                write (iout,*) "gradcorr5 in eello5 before loop"
7594 !                do iii=1,nres
7595 !                  write (iout,'(i5,3f10.5)')
7596 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7597 !                enddo
7598       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7599 !        write (iout,*) "corr loop i",i
7600         i1=i+1
7601         num_conti=num_cont_hb(i)
7602         num_conti1=num_cont_hb(i+1)
7603         do jj=1,num_conti
7604           j=jcont_hb(jj,i)
7605           jp=iabs(j)
7606           do kk=1,num_conti1
7607             j1=jcont_hb(kk,i1)
7608             jp1=iabs(j1)
7609 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7610 !     &         ' jj=',jj,' kk=',kk
7611 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7612             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7613                 .or. j.lt.0 .and. j1.gt.0) .and. &
7614                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7615 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7616 ! The system gains extra energy.
7617               n_corr=n_corr+1
7618               sqd1=dsqrt(d_cont(jj,i))
7619               sqd2=dsqrt(d_cont(kk,i1))
7620               sred_geom = sqd1*sqd2
7621               IF (sred_geom.lt.cutoff_corr) THEN
7622                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7623                   ekont,fprimcont)
7624 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7625 !d     &         ' jj=',jj,' kk=',kk
7626                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7627                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7628                 do l=1,3
7629                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7630                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7631                 enddo
7632                 n_corr1=n_corr1+1
7633 !d               write (iout,*) 'sred_geom=',sred_geom,
7634 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7635 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7636 !d               write (iout,*) "g_contij",g_contij
7637 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7638 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7639                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7640                 if (wcorr4.gt.0.0d0) &
7641                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7642                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7643                        write (iout,'(a6,4i5,0pf7.3)') &
7644                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7645 !                write (iout,*) "gradcorr5 before eello5"
7646 !                do iii=1,nres
7647 !                  write (iout,'(i5,3f10.5)')
7648 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7649 !                enddo
7650                 if (wcorr5.gt.0.0d0) &
7651                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7652 !                write (iout,*) "gradcorr5 after eello5"
7653 !                do iii=1,nres
7654 !                  write (iout,'(i5,3f10.5)')
7655 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7656 !                enddo
7657                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7658                        write (iout,'(a6,4i5,0pf7.3)') &
7659                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7660 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7661 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7662                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7663                      .or. wturn6.eq.0.0d0))then
7664 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7665                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7666                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7667                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7668 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7669 !d     &            'ecorr6=',ecorr6
7670 !d                write (iout,'(4e15.5)') sred_geom,
7671 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7672 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7673 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7674                 else if (wturn6.gt.0.0d0 &
7675                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7676 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7677                   eturn6=eturn6+eello_turn6(i,jj,kk)
7678                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7679                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7680 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7681                 endif
7682               ENDIF
7683 1111          continue
7684             endif
7685           enddo ! kk
7686         enddo ! jj
7687       enddo ! i
7688       do i=1,nres
7689         num_cont_hb(i)=num_cont_hb_old(i)
7690       enddo
7691 !                write (iout,*) "gradcorr5 in eello5"
7692 !                do iii=1,nres
7693 !                  write (iout,'(i5,3f10.5)')
7694 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7695 !                enddo
7696       return
7697       end subroutine multibody_eello
7698 !-----------------------------------------------------------------------------
7699       subroutine add_hb_contact_eello(ii,jj,itask)
7700 !      implicit real*8 (a-h,o-z)
7701 !      include "DIMENSIONS"
7702 !      include "COMMON.IOUNITS"
7703 !      include "COMMON.CONTACTS"
7704 !      integer,parameter :: maxconts=nres/4
7705       integer,parameter :: max_dim=70
7706       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7707 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7708 !      common /przechowalnia/ zapas
7709
7710       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7711       integer,dimension(4) ::itask
7712 !      write (iout,*) "itask",itask
7713       do i=1,2
7714         iproc=itask(i)
7715         if (iproc.gt.0) then
7716           do j=1,num_cont_hb(ii)
7717             jjc=jcont_hb(j,ii)
7718 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7719             if (jjc.eq.jj) then
7720               ncont_sent(iproc)=ncont_sent(iproc)+1
7721               nn=ncont_sent(iproc)
7722               zapas(1,nn,iproc)=ii
7723               zapas(2,nn,iproc)=jjc
7724               zapas(3,nn,iproc)=d_cont(j,ii)
7725               ind=3
7726               do kk=1,3
7727                 ind=ind+1
7728                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7729               enddo
7730               do kk=1,2
7731                 do ll=1,2
7732                   ind=ind+1
7733                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7734                 enddo
7735               enddo
7736               do jj=1,5
7737                 do kk=1,3
7738                   do ll=1,2
7739                     do mm=1,2
7740                       ind=ind+1
7741                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7742                     enddo
7743                   enddo
7744                 enddo
7745               enddo
7746               exit
7747             endif
7748           enddo
7749         endif
7750       enddo
7751       return
7752       end subroutine add_hb_contact_eello
7753 !-----------------------------------------------------------------------------
7754       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7755 !      implicit real*8 (a-h,o-z)
7756 !      include 'DIMENSIONS'
7757 !      include 'COMMON.IOUNITS'
7758 !      include 'COMMON.DERIV'
7759 !      include 'COMMON.INTERACT'
7760 !      include 'COMMON.CONTACTS'
7761       real(kind=8),dimension(3) :: gx,gx1
7762       logical :: lprn
7763 !el local variables
7764       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
7765       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
7766                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
7767                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
7768                    rlocshield
7769
7770       lprn=.false.
7771       eij=facont_hb(jj,i)
7772       ekl=facont_hb(kk,k)
7773       ees0pij=ees0p(jj,i)
7774       ees0pkl=ees0p(kk,k)
7775       ees0mij=ees0m(jj,i)
7776       ees0mkl=ees0m(kk,k)
7777       ekont=eij*ekl
7778       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7779 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7780 ! Following 4 lines for diagnostics.
7781 !d    ees0pkl=0.0D0
7782 !d    ees0pij=1.0D0
7783 !d    ees0mkl=0.0D0
7784 !d    ees0mij=1.0D0
7785 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7786 !     & 'Contacts ',i,j,
7787 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7788 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7789 !     & 'gradcorr_long'
7790 ! Calculate the multi-body contribution to energy.
7791 !      ecorr=ecorr+ekont*ees
7792 ! Calculate multi-body contributions to the gradient.
7793       coeffpees0pij=coeffp*ees0pij
7794       coeffmees0mij=coeffm*ees0mij
7795       coeffpees0pkl=coeffp*ees0pkl
7796       coeffmees0mkl=coeffm*ees0mkl
7797       do ll=1,3
7798 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7799         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
7800         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
7801         coeffmees0mkl*gacontm_hb1(ll,jj,i))
7802         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
7803         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
7804         coeffmees0mkl*gacontm_hb2(ll,jj,i))
7805 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7806         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
7807         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
7808         coeffmees0mij*gacontm_hb1(ll,kk,k))
7809         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
7810         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
7811         coeffmees0mij*gacontm_hb2(ll,kk,k))
7812         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
7813            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
7814            coeffmees0mkl*gacontm_hb3(ll,jj,i))
7815         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7816         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7817         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
7818            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
7819            coeffmees0mij*gacontm_hb3(ll,kk,k))
7820         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7821         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7822 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7823       enddo
7824 !      write (iout,*)
7825 !grad      do m=i+1,j-1
7826 !grad        do ll=1,3
7827 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7828 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7829 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7830 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7831 !grad        enddo
7832 !grad      enddo
7833 !grad      do m=k+1,l-1
7834 !grad        do ll=1,3
7835 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7836 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
7837 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7838 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7839 !grad        enddo
7840 !grad      enddo
7841 !      write (iout,*) "ehbcorr",ekont*ees
7842       ehbcorr=ekont*ees
7843       if (shield_mode.gt.0) then
7844        j=ees0plist(jj,i)
7845        l=ees0plist(kk,k)
7846 !C        print *,i,j,fac_shield(i),fac_shield(j),
7847 !C     &fac_shield(k),fac_shield(l)
7848         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
7849            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7850           do ilist=1,ishield_list(i)
7851            iresshield=shield_list(ilist,i)
7852            do m=1,3
7853            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7854            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7855                    rlocshield  &
7856             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7857             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7858             +rlocshield
7859            enddo
7860           enddo
7861           do ilist=1,ishield_list(j)
7862            iresshield=shield_list(ilist,j)
7863            do m=1,3
7864            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7865            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7866                    rlocshield &
7867             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7868            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7869             +rlocshield
7870            enddo
7871           enddo
7872
7873           do ilist=1,ishield_list(k)
7874            iresshield=shield_list(ilist,k)
7875            do m=1,3
7876            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7877            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7878                    rlocshield &
7879             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7880            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7881             +rlocshield
7882            enddo
7883           enddo
7884           do ilist=1,ishield_list(l)
7885            iresshield=shield_list(ilist,l)
7886            do m=1,3
7887            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7888            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7889                    rlocshield &
7890             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7891            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7892             +rlocshield
7893            enddo
7894           enddo
7895           do m=1,3
7896             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
7897                    grad_shield(m,i)*ehbcorr/fac_shield(i)
7898             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
7899                    grad_shield(m,j)*ehbcorr/fac_shield(j)
7900             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
7901                    grad_shield(m,i)*ehbcorr/fac_shield(i)
7902             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
7903                    grad_shield(m,j)*ehbcorr/fac_shield(j)
7904
7905             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
7906                    grad_shield(m,k)*ehbcorr/fac_shield(k)
7907             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
7908                    grad_shield(m,l)*ehbcorr/fac_shield(l)
7909             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
7910                    grad_shield(m,k)*ehbcorr/fac_shield(k)
7911             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
7912                    grad_shield(m,l)*ehbcorr/fac_shield(l)
7913
7914            enddo
7915       endif
7916       endif
7917       return
7918       end function ehbcorr
7919 #ifdef MOMENT
7920 !-----------------------------------------------------------------------------
7921       subroutine dipole(i,j,jj)
7922 !      implicit real*8 (a-h,o-z)
7923 !      include 'DIMENSIONS'
7924 !      include 'COMMON.IOUNITS'
7925 !      include 'COMMON.CHAIN'
7926 !      include 'COMMON.FFIELD'
7927 !      include 'COMMON.DERIV'
7928 !      include 'COMMON.INTERACT'
7929 !      include 'COMMON.CONTACTS'
7930 !      include 'COMMON.TORSION'
7931 !      include 'COMMON.VAR'
7932 !      include 'COMMON.GEO'
7933       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
7934       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
7935       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
7936
7937       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
7938       allocate(dipderx(3,5,4,maxconts,nres))
7939 !
7940
7941       iti1 = itortyp(itype(i+1))
7942       if (j.lt.nres-1) then
7943         itj1 = itortyp(itype(j+1))
7944       else
7945         itj1=ntortyp+1
7946       endif
7947       do iii=1,2
7948         dipi(iii,1)=Ub2(iii,i)
7949         dipderi(iii)=Ub2der(iii,i)
7950         dipi(iii,2)=b1(iii,iti1)
7951         dipj(iii,1)=Ub2(iii,j)
7952         dipderj(iii)=Ub2der(iii,j)
7953         dipj(iii,2)=b1(iii,itj1)
7954       enddo
7955       kkk=0
7956       do iii=1,2
7957         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7958         do jjj=1,2
7959           kkk=kkk+1
7960           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7961         enddo
7962       enddo
7963       do kkk=1,5
7964         do lll=1,3
7965           mmm=0
7966           do iii=1,2
7967             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
7968               auxvec(1))
7969             do jjj=1,2
7970               mmm=mmm+1
7971               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7972             enddo
7973           enddo
7974         enddo
7975       enddo
7976       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7977       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7978       do iii=1,2
7979         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7980       enddo
7981       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7982       do iii=1,2
7983         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7984       enddo
7985       return
7986       end subroutine dipole
7987 #endif
7988 !-----------------------------------------------------------------------------
7989       subroutine calc_eello(i,j,k,l,jj,kk)
7990 !
7991 ! This subroutine computes matrices and vectors needed to calculate
7992 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
7993 !
7994       use comm_kut
7995 !      implicit real*8 (a-h,o-z)
7996 !      include 'DIMENSIONS'
7997 !      include 'COMMON.IOUNITS'
7998 !      include 'COMMON.CHAIN'
7999 !      include 'COMMON.DERIV'
8000 !      include 'COMMON.INTERACT'
8001 !      include 'COMMON.CONTACTS'
8002 !      include 'COMMON.TORSION'
8003 !      include 'COMMON.VAR'
8004 !      include 'COMMON.GEO'
8005 !      include 'COMMON.FFIELD'
8006       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8007       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8008       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8009               itj1
8010 !el      logical :: lprn
8011 !el      common /kutas/ lprn
8012 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8013 !d     & ' jj=',jj,' kk=',kk
8014 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8015 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8016 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8017       do iii=1,2
8018         do jjj=1,2
8019           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8020           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8021         enddo
8022       enddo
8023       call transpose2(aa1(1,1),aa1t(1,1))
8024       call transpose2(aa2(1,1),aa2t(1,1))
8025       do kkk=1,5
8026         do lll=1,3
8027           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8028             aa1tder(1,1,lll,kkk))
8029           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8030             aa2tder(1,1,lll,kkk))
8031         enddo
8032       enddo
8033       if (l.eq.j+1) then
8034 ! parallel orientation of the two CA-CA-CA frames.
8035         if (i.gt.1) then
8036           iti=itortyp(itype(i))
8037         else
8038           iti=ntortyp+1
8039         endif
8040         itk1=itortyp(itype(k+1))
8041         itj=itortyp(itype(j))
8042         if (l.lt.nres-1) then
8043           itl1=itortyp(itype(l+1))
8044         else
8045           itl1=ntortyp+1
8046         endif
8047 ! A1 kernel(j+1) A2T
8048 !d        do iii=1,2
8049 !d          write (iout,'(3f10.5,5x,3f10.5)')
8050 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8051 !d        enddo
8052         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8053          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8054          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8055 ! Following matrices are needed only for 6-th order cumulants
8056         IF (wcorr6.gt.0.0d0) THEN
8057         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8058          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8059          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8060         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8061          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8062          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8063          ADtEAderx(1,1,1,1,1,1))
8064         lprn=.false.
8065         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8066          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8067          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8068          ADtEA1derx(1,1,1,1,1,1))
8069         ENDIF
8070 ! End 6-th order cumulants
8071 !d        lprn=.false.
8072 !d        if (lprn) then
8073 !d        write (2,*) 'In calc_eello6'
8074 !d        do iii=1,2
8075 !d          write (2,*) 'iii=',iii
8076 !d          do kkk=1,5
8077 !d            write (2,*) 'kkk=',kkk
8078 !d            do jjj=1,2
8079 !d              write (2,'(3(2f10.5),5x)')
8080 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8081 !d            enddo
8082 !d          enddo
8083 !d        enddo
8084 !d        endif
8085         call transpose2(EUgder(1,1,k),auxmat(1,1))
8086         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8087         call transpose2(EUg(1,1,k),auxmat(1,1))
8088         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8089         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8090         do iii=1,2
8091           do kkk=1,5
8092             do lll=1,3
8093               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8094                 EAEAderx(1,1,lll,kkk,iii,1))
8095             enddo
8096           enddo
8097         enddo
8098 ! A1T kernel(i+1) A2
8099         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8100          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8101          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8102 ! Following matrices are needed only for 6-th order cumulants
8103         IF (wcorr6.gt.0.0d0) THEN
8104         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8105          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8106          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8107         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8108          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8109          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8110          ADtEAderx(1,1,1,1,1,2))
8111         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8112          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8113          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8114          ADtEA1derx(1,1,1,1,1,2))
8115         ENDIF
8116 ! End 6-th order cumulants
8117         call transpose2(EUgder(1,1,l),auxmat(1,1))
8118         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8119         call transpose2(EUg(1,1,l),auxmat(1,1))
8120         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8121         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8122         do iii=1,2
8123           do kkk=1,5
8124             do lll=1,3
8125               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8126                 EAEAderx(1,1,lll,kkk,iii,2))
8127             enddo
8128           enddo
8129         enddo
8130 ! AEAb1 and AEAb2
8131 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8132 ! They are needed only when the fifth- or the sixth-order cumulants are
8133 ! indluded.
8134         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8135         call transpose2(AEA(1,1,1),auxmat(1,1))
8136         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8137         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8138         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8139         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8140         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8141         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8142         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8143         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8144         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8145         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8146         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8147         call transpose2(AEA(1,1,2),auxmat(1,1))
8148         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8149         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8150         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8151         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8152         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8153         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8154         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8155         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8156         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8157         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8158         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8159 ! Calculate the Cartesian derivatives of the vectors.
8160         do iii=1,2
8161           do kkk=1,5
8162             do lll=1,3
8163               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8164               call matvec2(auxmat(1,1),b1(1,iti),&
8165                 AEAb1derx(1,lll,kkk,iii,1,1))
8166               call matvec2(auxmat(1,1),Ub2(1,i),&
8167                 AEAb2derx(1,lll,kkk,iii,1,1))
8168               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8169                 AEAb1derx(1,lll,kkk,iii,2,1))
8170               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8171                 AEAb2derx(1,lll,kkk,iii,2,1))
8172               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8173               call matvec2(auxmat(1,1),b1(1,itj),&
8174                 AEAb1derx(1,lll,kkk,iii,1,2))
8175               call matvec2(auxmat(1,1),Ub2(1,j),&
8176                 AEAb2derx(1,lll,kkk,iii,1,2))
8177               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8178                 AEAb1derx(1,lll,kkk,iii,2,2))
8179               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8180                 AEAb2derx(1,lll,kkk,iii,2,2))
8181             enddo
8182           enddo
8183         enddo
8184         ENDIF
8185 ! End vectors
8186       else
8187 ! Antiparallel orientation of the two CA-CA-CA frames.
8188         if (i.gt.1) then
8189           iti=itortyp(itype(i))
8190         else
8191           iti=ntortyp+1
8192         endif
8193         itk1=itortyp(itype(k+1))
8194         itl=itortyp(itype(l))
8195         itj=itortyp(itype(j))
8196         if (j.lt.nres-1) then
8197           itj1=itortyp(itype(j+1))
8198         else
8199           itj1=ntortyp+1
8200         endif
8201 ! A2 kernel(j-1)T A1T
8202         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8203          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8204          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8205 ! Following matrices are needed only for 6-th order cumulants
8206         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8207            j.eq.i+4 .and. l.eq.i+3)) THEN
8208         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8209          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8210          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8211         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8212          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8213          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8214          ADtEAderx(1,1,1,1,1,1))
8215         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8216          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8217          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8218          ADtEA1derx(1,1,1,1,1,1))
8219         ENDIF
8220 ! End 6-th order cumulants
8221         call transpose2(EUgder(1,1,k),auxmat(1,1))
8222         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8223         call transpose2(EUg(1,1,k),auxmat(1,1))
8224         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8225         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8226         do iii=1,2
8227           do kkk=1,5
8228             do lll=1,3
8229               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8230                 EAEAderx(1,1,lll,kkk,iii,1))
8231             enddo
8232           enddo
8233         enddo
8234 ! A2T kernel(i+1)T A1
8235         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8236          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8237          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8238 ! Following matrices are needed only for 6-th order cumulants
8239         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8240            j.eq.i+4 .and. l.eq.i+3)) THEN
8241         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8242          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8243          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8244         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8245          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8246          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8247          ADtEAderx(1,1,1,1,1,2))
8248         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8249          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8250          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8251          ADtEA1derx(1,1,1,1,1,2))
8252         ENDIF
8253 ! End 6-th order cumulants
8254         call transpose2(EUgder(1,1,j),auxmat(1,1))
8255         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8256         call transpose2(EUg(1,1,j),auxmat(1,1))
8257         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8258         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8259         do iii=1,2
8260           do kkk=1,5
8261             do lll=1,3
8262               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8263                 EAEAderx(1,1,lll,kkk,iii,2))
8264             enddo
8265           enddo
8266         enddo
8267 ! AEAb1 and AEAb2
8268 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8269 ! They are needed only when the fifth- or the sixth-order cumulants are
8270 ! indluded.
8271         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8272           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8273         call transpose2(AEA(1,1,1),auxmat(1,1))
8274         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8275         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8276         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8277         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8278         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8279         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8280         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8281         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8282         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8283         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8284         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8285         call transpose2(AEA(1,1,2),auxmat(1,1))
8286         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8287         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8288         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8289         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8290         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8291         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8292         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8293         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8294         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8295         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8296         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8297 ! Calculate the Cartesian derivatives of the vectors.
8298         do iii=1,2
8299           do kkk=1,5
8300             do lll=1,3
8301               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8302               call matvec2(auxmat(1,1),b1(1,iti),&
8303                 AEAb1derx(1,lll,kkk,iii,1,1))
8304               call matvec2(auxmat(1,1),Ub2(1,i),&
8305                 AEAb2derx(1,lll,kkk,iii,1,1))
8306               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8307                 AEAb1derx(1,lll,kkk,iii,2,1))
8308               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8309                 AEAb2derx(1,lll,kkk,iii,2,1))
8310               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8311               call matvec2(auxmat(1,1),b1(1,itl),&
8312                 AEAb1derx(1,lll,kkk,iii,1,2))
8313               call matvec2(auxmat(1,1),Ub2(1,l),&
8314                 AEAb2derx(1,lll,kkk,iii,1,2))
8315               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8316                 AEAb1derx(1,lll,kkk,iii,2,2))
8317               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8318                 AEAb2derx(1,lll,kkk,iii,2,2))
8319             enddo
8320           enddo
8321         enddo
8322         ENDIF
8323 ! End vectors
8324       endif
8325       return
8326       end subroutine calc_eello
8327 !-----------------------------------------------------------------------------
8328       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8329       use comm_kut
8330       implicit none
8331       integer :: nderg
8332       logical :: transp
8333       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8334       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8335       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8336       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8337       integer :: iii,kkk,lll
8338       integer :: jjj,mmm
8339 !el      logical :: lprn
8340 !el      common /kutas/ lprn
8341       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8342       do iii=1,nderg
8343         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8344           AKAderg(1,1,iii))
8345       enddo
8346 !d      if (lprn) write (2,*) 'In kernel'
8347       do kkk=1,5
8348 !d        if (lprn) write (2,*) 'kkk=',kkk
8349         do lll=1,3
8350           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8351             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8352 !d          if (lprn) then
8353 !d            write (2,*) 'lll=',lll
8354 !d            write (2,*) 'iii=1'
8355 !d            do jjj=1,2
8356 !d              write (2,'(3(2f10.5),5x)')
8357 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8358 !d            enddo
8359 !d          endif
8360           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8361             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8362 !d          if (lprn) then
8363 !d            write (2,*) 'lll=',lll
8364 !d            write (2,*) 'iii=2'
8365 !d            do jjj=1,2
8366 !d              write (2,'(3(2f10.5),5x)')
8367 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8368 !d            enddo
8369 !d          endif
8370         enddo
8371       enddo
8372       return
8373       end subroutine kernel
8374 !-----------------------------------------------------------------------------
8375       real(kind=8) function eello4(i,j,k,l,jj,kk)
8376 !      implicit real*8 (a-h,o-z)
8377 !      include 'DIMENSIONS'
8378 !      include 'COMMON.IOUNITS'
8379 !      include 'COMMON.CHAIN'
8380 !      include 'COMMON.DERIV'
8381 !      include 'COMMON.INTERACT'
8382 !      include 'COMMON.CONTACTS'
8383 !      include 'COMMON.TORSION'
8384 !      include 'COMMON.VAR'
8385 !      include 'COMMON.GEO'
8386       real(kind=8),dimension(2,2) :: pizda
8387       real(kind=8),dimension(3) :: ggg1,ggg2
8388       real(kind=8) ::  eel4,glongij,glongkl
8389       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8390 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8391 !d        eello4=0.0d0
8392 !d        return
8393 !d      endif
8394 !d      print *,'eello4:',i,j,k,l,jj,kk
8395 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8396 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8397 !old      eij=facont_hb(jj,i)
8398 !old      ekl=facont_hb(kk,k)
8399 !old      ekont=eij*ekl
8400       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8401 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8402       gcorr_loc(k-1)=gcorr_loc(k-1) &
8403          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8404       if (l.eq.j+1) then
8405         gcorr_loc(l-1)=gcorr_loc(l-1) &
8406            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8407       else
8408         gcorr_loc(j-1)=gcorr_loc(j-1) &
8409            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8410       endif
8411       do iii=1,2
8412         do kkk=1,5
8413           do lll=1,3
8414             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8415                               -EAEAderx(2,2,lll,kkk,iii,1)
8416 !d            derx(lll,kkk,iii)=0.0d0
8417           enddo
8418         enddo
8419       enddo
8420 !d      gcorr_loc(l-1)=0.0d0
8421 !d      gcorr_loc(j-1)=0.0d0
8422 !d      gcorr_loc(k-1)=0.0d0
8423 !d      eel4=1.0d0
8424 !d      write (iout,*)'Contacts have occurred for peptide groups',
8425 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8426 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8427       if (j.lt.nres-1) then
8428         j1=j+1
8429         j2=j-1
8430       else
8431         j1=j-1
8432         j2=j-2
8433       endif
8434       if (l.lt.nres-1) then
8435         l1=l+1
8436         l2=l-1
8437       else
8438         l1=l-1
8439         l2=l-2
8440       endif
8441       do ll=1,3
8442 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8443 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8444         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8445         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8446 !grad        ghalf=0.5d0*ggg1(ll)
8447         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8448         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8449         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8450         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8451         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8452         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8453 !grad        ghalf=0.5d0*ggg2(ll)
8454         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8455         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8456         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8457         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8458         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8459         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8460       enddo
8461 !grad      do m=i+1,j-1
8462 !grad        do ll=1,3
8463 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8464 !grad        enddo
8465 !grad      enddo
8466 !grad      do m=k+1,l-1
8467 !grad        do ll=1,3
8468 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8469 !grad        enddo
8470 !grad      enddo
8471 !grad      do m=i+2,j2
8472 !grad        do ll=1,3
8473 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8474 !grad        enddo
8475 !grad      enddo
8476 !grad      do m=k+2,l2
8477 !grad        do ll=1,3
8478 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8479 !grad        enddo
8480 !grad      enddo
8481 !d      do iii=1,nres-3
8482 !d        write (2,*) iii,gcorr_loc(iii)
8483 !d      enddo
8484       eello4=ekont*eel4
8485 !d      write (2,*) 'ekont',ekont
8486 !d      write (iout,*) 'eello4',ekont*eel4
8487       return
8488       end function eello4
8489 !-----------------------------------------------------------------------------
8490       real(kind=8) function eello5(i,j,k,l,jj,kk)
8491 !      implicit real*8 (a-h,o-z)
8492 !      include 'DIMENSIONS'
8493 !      include 'COMMON.IOUNITS'
8494 !      include 'COMMON.CHAIN'
8495 !      include 'COMMON.DERIV'
8496 !      include 'COMMON.INTERACT'
8497 !      include 'COMMON.CONTACTS'
8498 !      include 'COMMON.TORSION'
8499 !      include 'COMMON.VAR'
8500 !      include 'COMMON.GEO'
8501       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8502       real(kind=8),dimension(2) :: vv
8503       real(kind=8),dimension(3) :: ggg1,ggg2
8504       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8505       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8506       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8507 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8508 !                                                                              C
8509 !                            Parallel chains                                   C
8510 !                                                                              C
8511 !          o             o                   o             o                   C
8512 !         /l\           / \             \   / \           / \   /              C
8513 !        /   \         /   \             \ /   \         /   \ /               C
8514 !       j| o |l1       | o |              o| o |         | o |o                C
8515 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8516 !      \i/   \         /   \ /             /   \         /   \                 C
8517 !       o    k1             o                                                  C
8518 !         (I)          (II)                (III)          (IV)                 C
8519 !                                                                              C
8520 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8521 !                                                                              C
8522 !                            Antiparallel chains                               C
8523 !                                                                              C
8524 !          o             o                   o             o                   C
8525 !         /j\           / \             \   / \           / \   /              C
8526 !        /   \         /   \             \ /   \         /   \ /               C
8527 !      j1| o |l        | o |              o| o |         | o |o                C
8528 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8529 !      \i/   \         /   \ /             /   \         /   \                 C
8530 !       o     k1            o                                                  C
8531 !         (I)          (II)                (III)          (IV)                 C
8532 !                                                                              C
8533 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8534 !                                                                              C
8535 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8536 !                                                                              C
8537 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8538 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8539 !d        eello5=0.0d0
8540 !d        return
8541 !d      endif
8542 !d      write (iout,*)
8543 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8544 !d     &   ' and',k,l
8545       itk=itortyp(itype(k))
8546       itl=itortyp(itype(l))
8547       itj=itortyp(itype(j))
8548       eello5_1=0.0d0
8549       eello5_2=0.0d0
8550       eello5_3=0.0d0
8551       eello5_4=0.0d0
8552 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8553 !d     &   eel5_3_num,eel5_4_num)
8554       do iii=1,2
8555         do kkk=1,5
8556           do lll=1,3
8557             derx(lll,kkk,iii)=0.0d0
8558           enddo
8559         enddo
8560       enddo
8561 !d      eij=facont_hb(jj,i)
8562 !d      ekl=facont_hb(kk,k)
8563 !d      ekont=eij*ekl
8564 !d      write (iout,*)'Contacts have occurred for peptide groups',
8565 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8566 !d      goto 1111
8567 ! Contribution from the graph I.
8568 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8569 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8570       call transpose2(EUg(1,1,k),auxmat(1,1))
8571       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8572       vv(1)=pizda(1,1)-pizda(2,2)
8573       vv(2)=pizda(1,2)+pizda(2,1)
8574       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8575        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8576 ! Explicit gradient in virtual-dihedral angles.
8577       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8578        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8579        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8580       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8581       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8582       vv(1)=pizda(1,1)-pizda(2,2)
8583       vv(2)=pizda(1,2)+pizda(2,1)
8584       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8585        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8586        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8587       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8588       vv(1)=pizda(1,1)-pizda(2,2)
8589       vv(2)=pizda(1,2)+pizda(2,1)
8590       if (l.eq.j+1) then
8591         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8592          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8593          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8594       else
8595         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8596          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8597          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8598       endif
8599 ! Cartesian gradient
8600       do iii=1,2
8601         do kkk=1,5
8602           do lll=1,3
8603             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8604               pizda(1,1))
8605             vv(1)=pizda(1,1)-pizda(2,2)
8606             vv(2)=pizda(1,2)+pizda(2,1)
8607             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8608              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8609              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8610           enddo
8611         enddo
8612       enddo
8613 !      goto 1112
8614 !1111  continue
8615 ! Contribution from graph II
8616       call transpose2(EE(1,1,itk),auxmat(1,1))
8617       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8618       vv(1)=pizda(1,1)+pizda(2,2)
8619       vv(2)=pizda(2,1)-pizda(1,2)
8620       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8621        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8622 ! Explicit gradient in virtual-dihedral angles.
8623       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8624        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8625       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8626       vv(1)=pizda(1,1)+pizda(2,2)
8627       vv(2)=pizda(2,1)-pizda(1,2)
8628       if (l.eq.j+1) then
8629         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8630          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8631          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8632       else
8633         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8634          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8635          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8636       endif
8637 ! Cartesian gradient
8638       do iii=1,2
8639         do kkk=1,5
8640           do lll=1,3
8641             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8642               pizda(1,1))
8643             vv(1)=pizda(1,1)+pizda(2,2)
8644             vv(2)=pizda(2,1)-pizda(1,2)
8645             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8646              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8647              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8648           enddo
8649         enddo
8650       enddo
8651 !d      goto 1112
8652 !d1111  continue
8653       if (l.eq.j+1) then
8654 !d        goto 1110
8655 ! Parallel orientation
8656 ! Contribution from graph III
8657         call transpose2(EUg(1,1,l),auxmat(1,1))
8658         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8659         vv(1)=pizda(1,1)-pizda(2,2)
8660         vv(2)=pizda(1,2)+pizda(2,1)
8661         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8662          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8663 ! Explicit gradient in virtual-dihedral angles.
8664         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8665          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8666          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8667         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8668         vv(1)=pizda(1,1)-pizda(2,2)
8669         vv(2)=pizda(1,2)+pizda(2,1)
8670         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8671          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8672          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8673         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8674         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8675         vv(1)=pizda(1,1)-pizda(2,2)
8676         vv(2)=pizda(1,2)+pizda(2,1)
8677         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8678          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8679          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8680 ! Cartesian gradient
8681         do iii=1,2
8682           do kkk=1,5
8683             do lll=1,3
8684               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8685                 pizda(1,1))
8686               vv(1)=pizda(1,1)-pizda(2,2)
8687               vv(2)=pizda(1,2)+pizda(2,1)
8688               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8689                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8690                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8691             enddo
8692           enddo
8693         enddo
8694 !d        goto 1112
8695 ! Contribution from graph IV
8696 !d1110    continue
8697         call transpose2(EE(1,1,itl),auxmat(1,1))
8698         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8699         vv(1)=pizda(1,1)+pizda(2,2)
8700         vv(2)=pizda(2,1)-pizda(1,2)
8701         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8702          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8703 ! Explicit gradient in virtual-dihedral angles.
8704         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8705          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8706         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8707         vv(1)=pizda(1,1)+pizda(2,2)
8708         vv(2)=pizda(2,1)-pizda(1,2)
8709         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8710          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8711          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8712 ! Cartesian gradient
8713         do iii=1,2
8714           do kkk=1,5
8715             do lll=1,3
8716               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8717                 pizda(1,1))
8718               vv(1)=pizda(1,1)+pizda(2,2)
8719               vv(2)=pizda(2,1)-pizda(1,2)
8720               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8721                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8722                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8723             enddo
8724           enddo
8725         enddo
8726       else
8727 ! Antiparallel orientation
8728 ! Contribution from graph III
8729 !        goto 1110
8730         call transpose2(EUg(1,1,j),auxmat(1,1))
8731         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8732         vv(1)=pizda(1,1)-pizda(2,2)
8733         vv(2)=pizda(1,2)+pizda(2,1)
8734         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8735          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8736 ! Explicit gradient in virtual-dihedral angles.
8737         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8738          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8739          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8740         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8741         vv(1)=pizda(1,1)-pizda(2,2)
8742         vv(2)=pizda(1,2)+pizda(2,1)
8743         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8744          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
8745          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8746         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8747         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8748         vv(1)=pizda(1,1)-pizda(2,2)
8749         vv(2)=pizda(1,2)+pizda(2,1)
8750         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8751          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
8752          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8753 ! Cartesian gradient
8754         do iii=1,2
8755           do kkk=1,5
8756             do lll=1,3
8757               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8758                 pizda(1,1))
8759               vv(1)=pizda(1,1)-pizda(2,2)
8760               vv(2)=pizda(1,2)+pizda(2,1)
8761               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8762                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
8763                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8764             enddo
8765           enddo
8766         enddo
8767 !d        goto 1112
8768 ! Contribution from graph IV
8769 1110    continue
8770         call transpose2(EE(1,1,itj),auxmat(1,1))
8771         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8772         vv(1)=pizda(1,1)+pizda(2,2)
8773         vv(2)=pizda(2,1)-pizda(1,2)
8774         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
8775          -0.5d0*scalar2(vv(1),Ctobr(1,j))
8776 ! Explicit gradient in virtual-dihedral angles.
8777         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8778          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8779         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8780         vv(1)=pizda(1,1)+pizda(2,2)
8781         vv(2)=pizda(2,1)-pizda(1,2)
8782         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8783          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
8784          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8785 ! Cartesian gradient
8786         do iii=1,2
8787           do kkk=1,5
8788             do lll=1,3
8789               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8790                 pizda(1,1))
8791               vv(1)=pizda(1,1)+pizda(2,2)
8792               vv(2)=pizda(2,1)-pizda(1,2)
8793               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8794                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
8795                -0.5d0*scalar2(vv(1),Ctobr(1,j))
8796             enddo
8797           enddo
8798         enddo
8799       endif
8800 1112  continue
8801       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8802 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8803 !d        write (2,*) 'ijkl',i,j,k,l
8804 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8805 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8806 !d      endif
8807 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8808 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8809 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8810 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8811       if (j.lt.nres-1) then
8812         j1=j+1
8813         j2=j-1
8814       else
8815         j1=j-1
8816         j2=j-2
8817       endif
8818       if (l.lt.nres-1) then
8819         l1=l+1
8820         l2=l-1
8821       else
8822         l1=l-1
8823         l2=l-2
8824       endif
8825 !d      eij=1.0d0
8826 !d      ekl=1.0d0
8827 !d      ekont=1.0d0
8828 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8829 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
8830 !        summed up outside the subrouine as for the other subroutines
8831 !        handling long-range interactions. The old code is commented out
8832 !        with "cgrad" to keep track of changes.
8833       do ll=1,3
8834 !grad        ggg1(ll)=eel5*g_contij(ll,1)
8835 !grad        ggg2(ll)=eel5*g_contij(ll,2)
8836         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8837         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8838 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8839 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8840 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8841 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8842 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8843 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8844 !     &   gradcorr5ij,
8845 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8846 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8847 !grad        ghalf=0.5d0*ggg1(ll)
8848 !d        ghalf=0.0d0
8849         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8850         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8851         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8852         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8853         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8854         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8855 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8856 !grad        ghalf=0.5d0*ggg2(ll)
8857         ghalf=0.0d0
8858         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8859         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8860         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8861         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8862         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8863         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8864       enddo
8865 !d      goto 1112
8866 !grad      do m=i+1,j-1
8867 !grad        do ll=1,3
8868 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8869 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8870 !grad        enddo
8871 !grad      enddo
8872 !grad      do m=k+1,l-1
8873 !grad        do ll=1,3
8874 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8875 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8876 !grad        enddo
8877 !grad      enddo
8878 !1112  continue
8879 !grad      do m=i+2,j2
8880 !grad        do ll=1,3
8881 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8882 !grad        enddo
8883 !grad      enddo
8884 !grad      do m=k+2,l2
8885 !grad        do ll=1,3
8886 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8887 !grad        enddo
8888 !grad      enddo
8889 !d      do iii=1,nres-3
8890 !d        write (2,*) iii,g_corr5_loc(iii)
8891 !d      enddo
8892       eello5=ekont*eel5
8893 !d      write (2,*) 'ekont',ekont
8894 !d      write (iout,*) 'eello5',ekont*eel5
8895       return
8896       end function eello5
8897 !-----------------------------------------------------------------------------
8898       real(kind=8) function eello6(i,j,k,l,jj,kk)
8899 !      implicit real*8 (a-h,o-z)
8900 !      include 'DIMENSIONS'
8901 !      include 'COMMON.IOUNITS'
8902 !      include 'COMMON.CHAIN'
8903 !      include 'COMMON.DERIV'
8904 !      include 'COMMON.INTERACT'
8905 !      include 'COMMON.CONTACTS'
8906 !      include 'COMMON.TORSION'
8907 !      include 'COMMON.VAR'
8908 !      include 'COMMON.GEO'
8909 !      include 'COMMON.FFIELD'
8910       real(kind=8),dimension(3) :: ggg1,ggg2
8911       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
8912                    eello6_6,eel6
8913       real(kind=8) :: gradcorr6ij,gradcorr6kl
8914       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8915 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8916 !d        eello6=0.0d0
8917 !d        return
8918 !d      endif
8919 !d      write (iout,*)
8920 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8921 !d     &   ' and',k,l
8922       eello6_1=0.0d0
8923       eello6_2=0.0d0
8924       eello6_3=0.0d0
8925       eello6_4=0.0d0
8926       eello6_5=0.0d0
8927       eello6_6=0.0d0
8928 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8929 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8930       do iii=1,2
8931         do kkk=1,5
8932           do lll=1,3
8933             derx(lll,kkk,iii)=0.0d0
8934           enddo
8935         enddo
8936       enddo
8937 !d      eij=facont_hb(jj,i)
8938 !d      ekl=facont_hb(kk,k)
8939 !d      ekont=eij*ekl
8940 !d      eij=1.0d0
8941 !d      ekl=1.0d0
8942 !d      ekont=1.0d0
8943       if (l.eq.j+1) then
8944         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8945         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8946         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8947         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8948         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8949         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8950       else
8951         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8952         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8953         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8954         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8955         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8956           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8957         else
8958           eello6_5=0.0d0
8959         endif
8960         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8961       endif
8962 ! If turn contributions are considered, they will be handled separately.
8963       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8964 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8965 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8966 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8967 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8968 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8969 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8970 !d      goto 1112
8971       if (j.lt.nres-1) then
8972         j1=j+1
8973         j2=j-1
8974       else
8975         j1=j-1
8976         j2=j-2
8977       endif
8978       if (l.lt.nres-1) then
8979         l1=l+1
8980         l2=l-1
8981       else
8982         l1=l-1
8983         l2=l-2
8984       endif
8985       do ll=1,3
8986 !grad        ggg1(ll)=eel6*g_contij(ll,1)
8987 !grad        ggg2(ll)=eel6*g_contij(ll,2)
8988 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8989 !grad        ghalf=0.5d0*ggg1(ll)
8990 !d        ghalf=0.0d0
8991         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8992         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8993         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8994         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8995         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8996         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8997         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8998         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8999 !grad        ghalf=0.5d0*ggg2(ll)
9000 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9001 !d        ghalf=0.0d0
9002         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9003         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9004         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9005         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9006         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9007         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9008       enddo
9009 !d      goto 1112
9010 !grad      do m=i+1,j-1
9011 !grad        do ll=1,3
9012 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9013 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9014 !grad        enddo
9015 !grad      enddo
9016 !grad      do m=k+1,l-1
9017 !grad        do ll=1,3
9018 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9019 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9020 !grad        enddo
9021 !grad      enddo
9022 !grad1112  continue
9023 !grad      do m=i+2,j2
9024 !grad        do ll=1,3
9025 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9026 !grad        enddo
9027 !grad      enddo
9028 !grad      do m=k+2,l2
9029 !grad        do ll=1,3
9030 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9031 !grad        enddo
9032 !grad      enddo
9033 !d      do iii=1,nres-3
9034 !d        write (2,*) iii,g_corr6_loc(iii)
9035 !d      enddo
9036       eello6=ekont*eel6
9037 !d      write (2,*) 'ekont',ekont
9038 !d      write (iout,*) 'eello6',ekont*eel6
9039       return
9040       end function eello6
9041 !-----------------------------------------------------------------------------
9042       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9043       use comm_kut
9044 !      implicit real*8 (a-h,o-z)
9045 !      include 'DIMENSIONS'
9046 !      include 'COMMON.IOUNITS'
9047 !      include 'COMMON.CHAIN'
9048 !      include 'COMMON.DERIV'
9049 !      include 'COMMON.INTERACT'
9050 !      include 'COMMON.CONTACTS'
9051 !      include 'COMMON.TORSION'
9052 !      include 'COMMON.VAR'
9053 !      include 'COMMON.GEO'
9054       real(kind=8),dimension(2) :: vv,vv1
9055       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9056       logical :: swap
9057 !el      logical :: lprn
9058 !el      common /kutas/ lprn
9059       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9060       real(kind=8) :: s1,s2,s3,s4,s5
9061 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9062 !                                                                              C
9063 !      Parallel       Antiparallel                                             C
9064 !                                                                              C
9065 !          o             o                                                     C
9066 !         /l\           /j\                                                    C
9067 !        /   \         /   \                                                   C
9068 !       /| o |         | o |\                                                  C
9069 !     \ j|/k\|  /   \  |/k\|l /                                                C
9070 !      \ /   \ /     \ /   \ /                                                 C
9071 !       o     o       o     o                                                  C
9072 !       i             i                                                        C
9073 !                                                                              C
9074 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9075       itk=itortyp(itype(k))
9076       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9077       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9078       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9079       call transpose2(EUgC(1,1,k),auxmat(1,1))
9080       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9081       vv1(1)=pizda1(1,1)-pizda1(2,2)
9082       vv1(2)=pizda1(1,2)+pizda1(2,1)
9083       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9084       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9085       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9086       s5=scalar2(vv(1),Dtobr2(1,i))
9087 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9088       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9089       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9090        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9091        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9092        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9093        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9094        +scalar2(vv(1),Dtobr2der(1,i)))
9095       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9096       vv1(1)=pizda1(1,1)-pizda1(2,2)
9097       vv1(2)=pizda1(1,2)+pizda1(2,1)
9098       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9099       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9100       if (l.eq.j+1) then
9101         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9102        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9103        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9104        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9105        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9106       else
9107         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9108        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9109        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9110        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9111        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9112       endif
9113       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9114       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9115       vv1(1)=pizda1(1,1)-pizda1(2,2)
9116       vv1(2)=pizda1(1,2)+pizda1(2,1)
9117       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9118        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9119        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9120        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9121       do iii=1,2
9122         if (swap) then
9123           ind=3-iii
9124         else
9125           ind=iii
9126         endif
9127         do kkk=1,5
9128           do lll=1,3
9129             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9130             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9131             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9132             call transpose2(EUgC(1,1,k),auxmat(1,1))
9133             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9134               pizda1(1,1))
9135             vv1(1)=pizda1(1,1)-pizda1(2,2)
9136             vv1(2)=pizda1(1,2)+pizda1(2,1)
9137             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9138             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9139              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9140             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9141              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9142             s5=scalar2(vv(1),Dtobr2(1,i))
9143             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9144           enddo
9145         enddo
9146       enddo
9147       return
9148       end function eello6_graph1
9149 !-----------------------------------------------------------------------------
9150       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9151       use comm_kut
9152 !      implicit real*8 (a-h,o-z)
9153 !      include 'DIMENSIONS'
9154 !      include 'COMMON.IOUNITS'
9155 !      include 'COMMON.CHAIN'
9156 !      include 'COMMON.DERIV'
9157 !      include 'COMMON.INTERACT'
9158 !      include 'COMMON.CONTACTS'
9159 !      include 'COMMON.TORSION'
9160 !      include 'COMMON.VAR'
9161 !      include 'COMMON.GEO'
9162       logical :: swap
9163       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9164       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9165 !el      logical :: lprn
9166 !el      common /kutas/ lprn
9167       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9168       real(kind=8) :: s2,s3,s4
9169 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9170 !                                                                              C
9171 !      Parallel       Antiparallel                                             C
9172 !                                                                              C
9173 !          o             o                                                     C
9174 !     \   /l\           /j\   /                                                C
9175 !      \ /   \         /   \ /                                                 C
9176 !       o| o |         | o |o                                                  C
9177 !     \ j|/k\|      \  |/k\|l                                                  C
9178 !      \ /   \       \ /   \                                                   C
9179 !       o             o                                                        C
9180 !       i             i                                                        C
9181 !                                                                              C
9182 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9183 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9184 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9185 !           but not in a cluster cumulant
9186 #ifdef MOMENT
9187       s1=dip(1,jj,i)*dip(1,kk,k)
9188 #endif
9189       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9190       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9191       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9192       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9193       call transpose2(EUg(1,1,k),auxmat(1,1))
9194       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9195       vv(1)=pizda(1,1)-pizda(2,2)
9196       vv(2)=pizda(1,2)+pizda(2,1)
9197       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9198 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9199 #ifdef MOMENT
9200       eello6_graph2=-(s1+s2+s3+s4)
9201 #else
9202       eello6_graph2=-(s2+s3+s4)
9203 #endif
9204 !      eello6_graph2=-s3
9205 ! Derivatives in gamma(i-1)
9206       if (i.gt.1) then
9207 #ifdef MOMENT
9208         s1=dipderg(1,jj,i)*dip(1,kk,k)
9209 #endif
9210         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9211         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9212         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9213         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9214 #ifdef MOMENT
9215         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9216 #else
9217         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9218 #endif
9219 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9220       endif
9221 ! Derivatives in gamma(k-1)
9222 #ifdef MOMENT
9223       s1=dip(1,jj,i)*dipderg(1,kk,k)
9224 #endif
9225       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9226       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9227       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9228       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9229       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9230       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9231       vv(1)=pizda(1,1)-pizda(2,2)
9232       vv(2)=pizda(1,2)+pizda(2,1)
9233       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9234 #ifdef MOMENT
9235       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9236 #else
9237       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9238 #endif
9239 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9240 ! Derivatives in gamma(j-1) or gamma(l-1)
9241       if (j.gt.1) then
9242 #ifdef MOMENT
9243         s1=dipderg(3,jj,i)*dip(1,kk,k)
9244 #endif
9245         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9246         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9247         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9248         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9249         vv(1)=pizda(1,1)-pizda(2,2)
9250         vv(2)=pizda(1,2)+pizda(2,1)
9251         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9252 #ifdef MOMENT
9253         if (swap) then
9254           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9255         else
9256           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9257         endif
9258 #endif
9259         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9260 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9261       endif
9262 ! Derivatives in gamma(l-1) or gamma(j-1)
9263       if (l.gt.1) then
9264 #ifdef MOMENT
9265         s1=dip(1,jj,i)*dipderg(3,kk,k)
9266 #endif
9267         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9268         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9269         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9270         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9271         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9272         vv(1)=pizda(1,1)-pizda(2,2)
9273         vv(2)=pizda(1,2)+pizda(2,1)
9274         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9275 #ifdef MOMENT
9276         if (swap) then
9277           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9278         else
9279           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9280         endif
9281 #endif
9282         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9283 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9284       endif
9285 ! Cartesian derivatives.
9286       if (lprn) then
9287         write (2,*) 'In eello6_graph2'
9288         do iii=1,2
9289           write (2,*) 'iii=',iii
9290           do kkk=1,5
9291             write (2,*) 'kkk=',kkk
9292             do jjj=1,2
9293               write (2,'(3(2f10.5),5x)') &
9294               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9295             enddo
9296           enddo
9297         enddo
9298       endif
9299       do iii=1,2
9300         do kkk=1,5
9301           do lll=1,3
9302 #ifdef MOMENT
9303             if (iii.eq.1) then
9304               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9305             else
9306               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9307             endif
9308 #endif
9309             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9310               auxvec(1))
9311             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9312             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9313               auxvec(1))
9314             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9315             call transpose2(EUg(1,1,k),auxmat(1,1))
9316             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9317               pizda(1,1))
9318             vv(1)=pizda(1,1)-pizda(2,2)
9319             vv(2)=pizda(1,2)+pizda(2,1)
9320             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9321 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9322 #ifdef MOMENT
9323             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9324 #else
9325             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9326 #endif
9327             if (swap) then
9328               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9329             else
9330               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9331             endif
9332           enddo
9333         enddo
9334       enddo
9335       return
9336       end function eello6_graph2
9337 !-----------------------------------------------------------------------------
9338       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9339 !      implicit real*8 (a-h,o-z)
9340 !      include 'DIMENSIONS'
9341 !      include 'COMMON.IOUNITS'
9342 !      include 'COMMON.CHAIN'
9343 !      include 'COMMON.DERIV'
9344 !      include 'COMMON.INTERACT'
9345 !      include 'COMMON.CONTACTS'
9346 !      include 'COMMON.TORSION'
9347 !      include 'COMMON.VAR'
9348 !      include 'COMMON.GEO'
9349       real(kind=8),dimension(2) :: vv,auxvec
9350       real(kind=8),dimension(2,2) :: pizda,auxmat
9351       logical :: swap
9352       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9353       real(kind=8) :: s1,s2,s3,s4
9354 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9355 !                                                                              C
9356 !      Parallel       Antiparallel                                             C
9357 !                                                                              C
9358 !          o             o                                                     C
9359 !         /l\   /   \   /j\                                                    C
9360 !        /   \ /     \ /   \                                                   C
9361 !       /| o |o       o| o |\                                                  C
9362 !       j|/k\|  /      |/k\|l /                                                C
9363 !        /   \ /       /   \ /                                                 C
9364 !       /     o       /     o                                                  C
9365 !       i             i                                                        C
9366 !                                                                              C
9367 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9368 !
9369 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9370 !           energy moment and not to the cluster cumulant.
9371       iti=itortyp(itype(i))
9372       if (j.lt.nres-1) then
9373         itj1=itortyp(itype(j+1))
9374       else
9375         itj1=ntortyp+1
9376       endif
9377       itk=itortyp(itype(k))
9378       itk1=itortyp(itype(k+1))
9379       if (l.lt.nres-1) then
9380         itl1=itortyp(itype(l+1))
9381       else
9382         itl1=ntortyp+1
9383       endif
9384 #ifdef MOMENT
9385       s1=dip(4,jj,i)*dip(4,kk,k)
9386 #endif
9387       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9388       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9389       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9390       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9391       call transpose2(EE(1,1,itk),auxmat(1,1))
9392       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9393       vv(1)=pizda(1,1)+pizda(2,2)
9394       vv(2)=pizda(2,1)-pizda(1,2)
9395       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9396 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9397 !d     & "sum",-(s2+s3+s4)
9398 #ifdef MOMENT
9399       eello6_graph3=-(s1+s2+s3+s4)
9400 #else
9401       eello6_graph3=-(s2+s3+s4)
9402 #endif
9403 !      eello6_graph3=-s4
9404 ! Derivatives in gamma(k-1)
9405       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9406       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9407       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9408       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9409 ! Derivatives in gamma(l-1)
9410       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9411       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9412       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9413       vv(1)=pizda(1,1)+pizda(2,2)
9414       vv(2)=pizda(2,1)-pizda(1,2)
9415       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9416       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9417 ! Cartesian derivatives.
9418       do iii=1,2
9419         do kkk=1,5
9420           do lll=1,3
9421 #ifdef MOMENT
9422             if (iii.eq.1) then
9423               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9424             else
9425               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9426             endif
9427 #endif
9428             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9429               auxvec(1))
9430             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9431             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9432               auxvec(1))
9433             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9434             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9435               pizda(1,1))
9436             vv(1)=pizda(1,1)+pizda(2,2)
9437             vv(2)=pizda(2,1)-pizda(1,2)
9438             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9439 #ifdef MOMENT
9440             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9441 #else
9442             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9443 #endif
9444             if (swap) then
9445               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9446             else
9447               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9448             endif
9449 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9450           enddo
9451         enddo
9452       enddo
9453       return
9454       end function eello6_graph3
9455 !-----------------------------------------------------------------------------
9456       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9457 !      implicit real*8 (a-h,o-z)
9458 !      include 'DIMENSIONS'
9459 !      include 'COMMON.IOUNITS'
9460 !      include 'COMMON.CHAIN'
9461 !      include 'COMMON.DERIV'
9462 !      include 'COMMON.INTERACT'
9463 !      include 'COMMON.CONTACTS'
9464 !      include 'COMMON.TORSION'
9465 !      include 'COMMON.VAR'
9466 !      include 'COMMON.GEO'
9467 !      include 'COMMON.FFIELD'
9468       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9469       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9470       logical :: swap
9471       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9472               iii,kkk,lll
9473       real(kind=8) :: s1,s2,s3,s4
9474 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9475 !                                                                              C
9476 !      Parallel       Antiparallel                                             C
9477 !                                                                              C
9478 !          o             o                                                     C
9479 !         /l\   /   \   /j\                                                    C
9480 !        /   \ /     \ /   \                                                   C
9481 !       /| o |o       o| o |\                                                  C
9482 !     \ j|/k\|      \  |/k\|l                                                  C
9483 !      \ /   \       \ /   \                                                   C
9484 !       o     \       o     \                                                  C
9485 !       i             i                                                        C
9486 !                                                                              C
9487 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9488 !
9489 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9490 !           energy moment and not to the cluster cumulant.
9491 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9492       iti=itortyp(itype(i))
9493       itj=itortyp(itype(j))
9494       if (j.lt.nres-1) then
9495         itj1=itortyp(itype(j+1))
9496       else
9497         itj1=ntortyp+1
9498       endif
9499       itk=itortyp(itype(k))
9500       if (k.lt.nres-1) then
9501         itk1=itortyp(itype(k+1))
9502       else
9503         itk1=ntortyp+1
9504       endif
9505       itl=itortyp(itype(l))
9506       if (l.lt.nres-1) then
9507         itl1=itortyp(itype(l+1))
9508       else
9509         itl1=ntortyp+1
9510       endif
9511 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9512 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9513 !d     & ' itl',itl,' itl1',itl1
9514 #ifdef MOMENT
9515       if (imat.eq.1) then
9516         s1=dip(3,jj,i)*dip(3,kk,k)
9517       else
9518         s1=dip(2,jj,j)*dip(2,kk,l)
9519       endif
9520 #endif
9521       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9522       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9523       if (j.eq.l+1) then
9524         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9525         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9526       else
9527         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9528         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9529       endif
9530       call transpose2(EUg(1,1,k),auxmat(1,1))
9531       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9532       vv(1)=pizda(1,1)-pizda(2,2)
9533       vv(2)=pizda(2,1)+pizda(1,2)
9534       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9535 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9536 #ifdef MOMENT
9537       eello6_graph4=-(s1+s2+s3+s4)
9538 #else
9539       eello6_graph4=-(s2+s3+s4)
9540 #endif
9541 ! Derivatives in gamma(i-1)
9542       if (i.gt.1) then
9543 #ifdef MOMENT
9544         if (imat.eq.1) then
9545           s1=dipderg(2,jj,i)*dip(3,kk,k)
9546         else
9547           s1=dipderg(4,jj,j)*dip(2,kk,l)
9548         endif
9549 #endif
9550         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9551         if (j.eq.l+1) then
9552           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9553           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9554         else
9555           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9556           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9557         endif
9558         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9559         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9560 !d          write (2,*) 'turn6 derivatives'
9561 #ifdef MOMENT
9562           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9563 #else
9564           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9565 #endif
9566         else
9567 #ifdef MOMENT
9568           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9569 #else
9570           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9571 #endif
9572         endif
9573       endif
9574 ! Derivatives in gamma(k-1)
9575 #ifdef MOMENT
9576       if (imat.eq.1) then
9577         s1=dip(3,jj,i)*dipderg(2,kk,k)
9578       else
9579         s1=dip(2,jj,j)*dipderg(4,kk,l)
9580       endif
9581 #endif
9582       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9583       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9584       if (j.eq.l+1) then
9585         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9586         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9587       else
9588         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9589         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9590       endif
9591       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9592       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9593       vv(1)=pizda(1,1)-pizda(2,2)
9594       vv(2)=pizda(2,1)+pizda(1,2)
9595       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9596       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9597 #ifdef MOMENT
9598         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9599 #else
9600         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9601 #endif
9602       else
9603 #ifdef MOMENT
9604         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9605 #else
9606         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9607 #endif
9608       endif
9609 ! Derivatives in gamma(j-1) or gamma(l-1)
9610       if (l.eq.j+1 .and. l.gt.1) then
9611         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9612         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9613         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9614         vv(1)=pizda(1,1)-pizda(2,2)
9615         vv(2)=pizda(2,1)+pizda(1,2)
9616         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9617         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9618       else if (j.gt.1) then
9619         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9620         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9621         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9622         vv(1)=pizda(1,1)-pizda(2,2)
9623         vv(2)=pizda(2,1)+pizda(1,2)
9624         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9625         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9626           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9627         else
9628           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9629         endif
9630       endif
9631 ! Cartesian derivatives.
9632       do iii=1,2
9633         do kkk=1,5
9634           do lll=1,3
9635 #ifdef MOMENT
9636             if (iii.eq.1) then
9637               if (imat.eq.1) then
9638                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9639               else
9640                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9641               endif
9642             else
9643               if (imat.eq.1) then
9644                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9645               else
9646                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9647               endif
9648             endif
9649 #endif
9650             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9651               auxvec(1))
9652             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9653             if (j.eq.l+1) then
9654               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9655                 b1(1,itj1),auxvec(1))
9656               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9657             else
9658               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9659                 b1(1,itl1),auxvec(1))
9660               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9661             endif
9662             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9663               pizda(1,1))
9664             vv(1)=pizda(1,1)-pizda(2,2)
9665             vv(2)=pizda(2,1)+pizda(1,2)
9666             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9667             if (swap) then
9668               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9669 #ifdef MOMENT
9670                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9671                    -(s1+s2+s4)
9672 #else
9673                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9674                    -(s2+s4)
9675 #endif
9676                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9677               else
9678 #ifdef MOMENT
9679                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9680 #else
9681                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9682 #endif
9683                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9684               endif
9685             else
9686 #ifdef MOMENT
9687               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9688 #else
9689               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9690 #endif
9691               if (l.eq.j+1) then
9692                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9693               else
9694                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9695               endif
9696             endif
9697           enddo
9698         enddo
9699       enddo
9700       return
9701       end function eello6_graph4
9702 !-----------------------------------------------------------------------------
9703       real(kind=8) function eello_turn6(i,jj,kk)
9704 !      implicit real*8 (a-h,o-z)
9705 !      include 'DIMENSIONS'
9706 !      include 'COMMON.IOUNITS'
9707 !      include 'COMMON.CHAIN'
9708 !      include 'COMMON.DERIV'
9709 !      include 'COMMON.INTERACT'
9710 !      include 'COMMON.CONTACTS'
9711 !      include 'COMMON.TORSION'
9712 !      include 'COMMON.VAR'
9713 !      include 'COMMON.GEO'
9714       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9715       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9716       real(kind=8),dimension(3) :: ggg1,ggg2
9717       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9718       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9719 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9720 !           the respective energy moment and not to the cluster cumulant.
9721 !el local variables
9722       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9723       integer :: j1,j2,l1,l2,ll
9724       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9725       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9726       s1=0.0d0
9727       s8=0.0d0
9728       s13=0.0d0
9729 !
9730       eello_turn6=0.0d0
9731       j=i+4
9732       k=i+1
9733       l=i+3
9734       iti=itortyp(itype(i))
9735       itk=itortyp(itype(k))
9736       itk1=itortyp(itype(k+1))
9737       itl=itortyp(itype(l))
9738       itj=itortyp(itype(j))
9739 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9740 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
9741 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9742 !d        eello6=0.0d0
9743 !d        return
9744 !d      endif
9745 !d      write (iout,*)
9746 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9747 !d     &   ' and',k,l
9748 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
9749       do iii=1,2
9750         do kkk=1,5
9751           do lll=1,3
9752             derx_turn(lll,kkk,iii)=0.0d0
9753           enddo
9754         enddo
9755       enddo
9756 !d      eij=1.0d0
9757 !d      ekl=1.0d0
9758 !d      ekont=1.0d0
9759       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9760 !d      eello6_5=0.0d0
9761 !d      write (2,*) 'eello6_5',eello6_5
9762 #ifdef MOMENT
9763       call transpose2(AEA(1,1,1),auxmat(1,1))
9764       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9765       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9766       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9767 #endif
9768       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9769       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9770       s2 = scalar2(b1(1,itk),vtemp1(1))
9771 #ifdef MOMENT
9772       call transpose2(AEA(1,1,2),atemp(1,1))
9773       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9774       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9775       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9776 #endif
9777       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9778       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9779       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9780 #ifdef MOMENT
9781       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9782       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9783       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9784       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9785       ss13 = scalar2(b1(1,itk),vtemp4(1))
9786       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9787 #endif
9788 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9789 !      s1=0.0d0
9790 !      s2=0.0d0
9791 !      s8=0.0d0
9792 !      s12=0.0d0
9793 !      s13=0.0d0
9794       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9795 ! Derivatives in gamma(i+2)
9796       s1d =0.0d0
9797       s8d =0.0d0
9798 #ifdef MOMENT
9799       call transpose2(AEA(1,1,1),auxmatd(1,1))
9800       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9801       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9802       call transpose2(AEAderg(1,1,2),atempd(1,1))
9803       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9804       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9805 #endif
9806       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9807       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9808       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9809 !      s1d=0.0d0
9810 !      s2d=0.0d0
9811 !      s8d=0.0d0
9812 !      s12d=0.0d0
9813 !      s13d=0.0d0
9814       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9815 ! Derivatives in gamma(i+3)
9816 #ifdef MOMENT
9817       call transpose2(AEA(1,1,1),auxmatd(1,1))
9818       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9819       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9820       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9821 #endif
9822       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9823       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9824       s2d = scalar2(b1(1,itk),vtemp1d(1))
9825 #ifdef MOMENT
9826       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9827       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9828 #endif
9829       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9830 #ifdef MOMENT
9831       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9832       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9833       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9834 #endif
9835 !      s1d=0.0d0
9836 !      s2d=0.0d0
9837 !      s8d=0.0d0
9838 !      s12d=0.0d0
9839 !      s13d=0.0d0
9840 #ifdef MOMENT
9841       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9842                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9843 #else
9844       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9845                     -0.5d0*ekont*(s2d+s12d)
9846 #endif
9847 ! Derivatives in gamma(i+4)
9848       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9849       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9850       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9851 #ifdef MOMENT
9852       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9853       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9854       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9855 #endif
9856 !      s1d=0.0d0
9857 !      s2d=0.0d0
9858 !      s8d=0.0d0
9859 !      s12d=0.0d0
9860 !      s13d=0.0d0
9861 #ifdef MOMENT
9862       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9863 #else
9864       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9865 #endif
9866 ! Derivatives in gamma(i+5)
9867 #ifdef MOMENT
9868       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9869       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9870       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9871 #endif
9872       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9873       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9874       s2d = scalar2(b1(1,itk),vtemp1d(1))
9875 #ifdef MOMENT
9876       call transpose2(AEA(1,1,2),atempd(1,1))
9877       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9878       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9879 #endif
9880       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9881       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9882 #ifdef MOMENT
9883       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9884       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9885       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9886 #endif
9887 !      s1d=0.0d0
9888 !      s2d=0.0d0
9889 !      s8d=0.0d0
9890 !      s12d=0.0d0
9891 !      s13d=0.0d0
9892 #ifdef MOMENT
9893       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9894                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9895 #else
9896       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9897                     -0.5d0*ekont*(s2d+s12d)
9898 #endif
9899 ! Cartesian derivatives
9900       do iii=1,2
9901         do kkk=1,5
9902           do lll=1,3
9903 #ifdef MOMENT
9904             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9905             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9906             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9907 #endif
9908             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9909             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
9910                 vtemp1d(1))
9911             s2d = scalar2(b1(1,itk),vtemp1d(1))
9912 #ifdef MOMENT
9913             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9914             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9915             s8d = -(atempd(1,1)+atempd(2,2))* &
9916                  scalar2(cc(1,1,itl),vtemp2(1))
9917 #endif
9918             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
9919                  auxmatd(1,1))
9920             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9921             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9922 !      s1d=0.0d0
9923 !      s2d=0.0d0
9924 !      s8d=0.0d0
9925 !      s12d=0.0d0
9926 !      s13d=0.0d0
9927 #ifdef MOMENT
9928             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9929               - 0.5d0*(s1d+s2d)
9930 #else
9931             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9932               - 0.5d0*s2d
9933 #endif
9934 #ifdef MOMENT
9935             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9936               - 0.5d0*(s8d+s12d)
9937 #else
9938             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9939               - 0.5d0*s12d
9940 #endif
9941           enddo
9942         enddo
9943       enddo
9944 #ifdef MOMENT
9945       do kkk=1,5
9946         do lll=1,3
9947           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
9948             achuj_tempd(1,1))
9949           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9950           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9951           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9952           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9953           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
9954             vtemp4d(1))
9955           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9956           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9957           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9958         enddo
9959       enddo
9960 #endif
9961 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9962 !d     &  16*eel_turn6_num
9963 !d      goto 1112
9964       if (j.lt.nres-1) then
9965         j1=j+1
9966         j2=j-1
9967       else
9968         j1=j-1
9969         j2=j-2
9970       endif
9971       if (l.lt.nres-1) then
9972         l1=l+1
9973         l2=l-1
9974       else
9975         l1=l-1
9976         l2=l-2
9977       endif
9978       do ll=1,3
9979 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9980 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9981 !grad        ghalf=0.5d0*ggg1(ll)
9982 !d        ghalf=0.0d0
9983         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9984         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9985         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
9986           +ekont*derx_turn(ll,2,1)
9987         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9988         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
9989           +ekont*derx_turn(ll,4,1)
9990         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9991         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9992         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9993 !grad        ghalf=0.5d0*ggg2(ll)
9994 !d        ghalf=0.0d0
9995         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
9996           +ekont*derx_turn(ll,2,2)
9997         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9998         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
9999           +ekont*derx_turn(ll,4,2)
10000         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10001         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10002         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10003       enddo
10004 !d      goto 1112
10005 !grad      do m=i+1,j-1
10006 !grad        do ll=1,3
10007 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10008 !grad        enddo
10009 !grad      enddo
10010 !grad      do m=k+1,l-1
10011 !grad        do ll=1,3
10012 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10013 !grad        enddo
10014 !grad      enddo
10015 !grad1112  continue
10016 !grad      do m=i+2,j2
10017 !grad        do ll=1,3
10018 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10019 !grad        enddo
10020 !grad      enddo
10021 !grad      do m=k+2,l2
10022 !grad        do ll=1,3
10023 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10024 !grad        enddo
10025 !grad      enddo
10026 !d      do iii=1,nres-3
10027 !d        write (2,*) iii,g_corr6_loc(iii)
10028 !d      enddo
10029       eello_turn6=ekont*eel_turn6
10030 !d      write (2,*) 'ekont',ekont
10031 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10032       return
10033       end function eello_turn6
10034 !-----------------------------------------------------------------------------
10035       subroutine MATVEC2(A1,V1,V2)
10036 !DIR$ INLINEALWAYS MATVEC2
10037 #ifndef OSF
10038 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10039 #endif
10040 !      implicit real*8 (a-h,o-z)
10041 !      include 'DIMENSIONS'
10042       real(kind=8),dimension(2) :: V1,V2
10043       real(kind=8),dimension(2,2) :: A1
10044       real(kind=8) :: vaux1,vaux2
10045 !      DO 1 I=1,2
10046 !        VI=0.0
10047 !        DO 3 K=1,2
10048 !    3     VI=VI+A1(I,K)*V1(K)
10049 !        Vaux(I)=VI
10050 !    1 CONTINUE
10051
10052       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10053       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10054
10055       v2(1)=vaux1
10056       v2(2)=vaux2
10057       end subroutine MATVEC2
10058 !-----------------------------------------------------------------------------
10059       subroutine MATMAT2(A1,A2,A3)
10060 #ifndef OSF
10061 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10062 #endif
10063 !      implicit real*8 (a-h,o-z)
10064 !      include 'DIMENSIONS'
10065       real(kind=8),dimension(2,2) :: A1,A2,A3
10066       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10067 !      DIMENSION AI3(2,2)
10068 !        DO  J=1,2
10069 !          A3IJ=0.0
10070 !          DO K=1,2
10071 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10072 !          enddo
10073 !          A3(I,J)=A3IJ
10074 !       enddo
10075 !      enddo
10076
10077       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10078       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10079       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10080       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10081
10082       A3(1,1)=AI3_11
10083       A3(2,1)=AI3_21
10084       A3(1,2)=AI3_12
10085       A3(2,2)=AI3_22
10086       end subroutine MATMAT2
10087 !-----------------------------------------------------------------------------
10088       real(kind=8) function scalar2(u,v)
10089 !DIR$ INLINEALWAYS scalar2
10090       implicit none
10091       real(kind=8),dimension(2) :: u,v
10092       real(kind=8) :: sc
10093       integer :: i
10094       scalar2=u(1)*v(1)+u(2)*v(2)
10095       return
10096       end function scalar2
10097 !-----------------------------------------------------------------------------
10098       subroutine transpose2(a,at)
10099 !DIR$ INLINEALWAYS transpose2
10100 #ifndef OSF
10101 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10102 #endif
10103       implicit none
10104       real(kind=8),dimension(2,2) :: a,at
10105       at(1,1)=a(1,1)
10106       at(1,2)=a(2,1)
10107       at(2,1)=a(1,2)
10108       at(2,2)=a(2,2)
10109       return
10110       end subroutine transpose2
10111 !-----------------------------------------------------------------------------
10112       subroutine transpose(n,a,at)
10113       implicit none
10114       integer :: n,i,j
10115       real(kind=8),dimension(n,n) :: a,at
10116       do i=1,n
10117         do j=1,n
10118           at(j,i)=a(i,j)
10119         enddo
10120       enddo
10121       return
10122       end subroutine transpose
10123 !-----------------------------------------------------------------------------
10124       subroutine prodmat3(a1,a2,kk,transp,prod)
10125 !DIR$ INLINEALWAYS prodmat3
10126 #ifndef OSF
10127 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10128 #endif
10129       implicit none
10130       integer :: i,j
10131       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10132       logical :: transp
10133 !rc      double precision auxmat(2,2),prod_(2,2)
10134
10135       if (transp) then
10136 !rc        call transpose2(kk(1,1),auxmat(1,1))
10137 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10138 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10139
10140            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10141        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10142            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10143        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10144            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10145        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10146            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10147        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10148
10149       else
10150 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10151 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10152
10153            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10154         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10155            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10156         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10157            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10158         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10159            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10160         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10161
10162       endif
10163 !      call transpose2(a2(1,1),a2t(1,1))
10164
10165 !rc      print *,transp
10166 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10167 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10168
10169       return
10170       end subroutine prodmat3
10171 !-----------------------------------------------------------------------------
10172 ! energy_p_new_barrier.F
10173 !-----------------------------------------------------------------------------
10174       subroutine sum_gradient
10175 !      implicit real*8 (a-h,o-z)
10176       use io_base, only: pdbout
10177 !      include 'DIMENSIONS'
10178 #ifndef ISNAN
10179       external proc_proc
10180 #ifdef WINPGI
10181 !MS$ATTRIBUTES C ::  proc_proc
10182 #endif
10183 #endif
10184 #ifdef MPI
10185       include 'mpif.h'
10186 #endif
10187       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10188                    gloc_scbuf !(3,maxres)
10189
10190       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10191 !#endif
10192 !el local variables
10193       integer :: i,j,k,ierror,ierr
10194       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10195                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10196                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10197                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10198                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10199                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10200                    gsccorr_max,gsccorrx_max,time00
10201
10202 !      include 'COMMON.SETUP'
10203 !      include 'COMMON.IOUNITS'
10204 !      include 'COMMON.FFIELD'
10205 !      include 'COMMON.DERIV'
10206 !      include 'COMMON.INTERACT'
10207 !      include 'COMMON.SBRIDGE'
10208 !      include 'COMMON.CHAIN'
10209 !      include 'COMMON.VAR'
10210 !      include 'COMMON.CONTROL'
10211 !      include 'COMMON.TIME1'
10212 !      include 'COMMON.MAXGRAD'
10213 !      include 'COMMON.SCCOR'
10214 #ifdef TIMING
10215       time01=MPI_Wtime()
10216 #endif
10217 #ifdef DEBUG
10218       write (iout,*) "sum_gradient gvdwc, gvdwx"
10219       do i=1,nres
10220         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10221          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10222       enddo
10223       call flush(iout)
10224 #endif
10225 #ifdef MPI
10226         gradbufc=0.0d0
10227         gradbufx=0.0d0
10228         gradbufc_sum=0.0d0
10229         gloc_scbuf=0.0d0
10230         glocbuf=0.0d0
10231 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10232         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10233           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10234 #endif
10235 !
10236 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10237 !            in virtual-bond-vector coordinates
10238 !
10239 #ifdef DEBUG
10240 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10241 !      do i=1,nres-1
10242 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10243 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10244 !      enddo
10245 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10246 !      do i=1,nres-1
10247 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10248 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10249 !      enddo
10250       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10251       do i=1,nres
10252         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10253          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10254          (gvdwc_scpp(j,i),j=1,3)
10255       enddo
10256       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10257       do i=1,nres
10258         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10259          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10260          (gelc_loc_long(j,i),j=1,3)
10261       enddo
10262       call flush(iout)
10263 #endif
10264 #ifdef SPLITELE
10265       do i=0,nct
10266         do j=1,3
10267           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10268                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10269                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10270                       wel_loc*gel_loc_long(j,i)+ &
10271                       wcorr*gradcorr_long(j,i)+ &
10272                       wcorr5*gradcorr5_long(j,i)+ &
10273                       wcorr6*gradcorr6_long(j,i)+ &
10274                       wturn6*gcorr6_turn_long(j,i)+ &
10275                       wstrain*ghpbc(j,i) &
10276                      +wliptran*gliptranc(j,i) &
10277                      +gradafm(j,i) &
10278                      +welec*gshieldc(j,i) &
10279                      +wcorr*gshieldc_ec(j,i) &
10280                      +wturn3*gshieldc_t3(j,i)&
10281                      +wturn4*gshieldc_t4(j,i)&
10282                      +wel_loc*gshieldc_ll(j,i)&
10283                      +wtube*gg_tube(j,i)
10284
10285
10286
10287         enddo
10288       enddo
10289 #else
10290       do i=0,nct
10291         do j=1,3
10292           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10293                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10294                       welec*gelc_long(j,i)+ &
10295                       wbond*gradb(j,i)+ &
10296                       wel_loc*gel_loc_long(j,i)+ &
10297                       wcorr*gradcorr_long(j,i)+ &
10298                       wcorr5*gradcorr5_long(j,i)+ &
10299                       wcorr6*gradcorr6_long(j,i)+ &
10300                       wturn6*gcorr6_turn_long(j,i)+ &
10301                       wstrain*ghpbc(j,i) &
10302                      +wliptran*gliptranc(j,i) &
10303                      +gradafm(j,i) &
10304                      +welec*gshieldc(j,i)&
10305                      +wcorr*gshieldc_ec(j,i) &
10306                      +wturn4*gshieldc_t4(j,i) &
10307                      +wel_loc*gshieldc_ll(j,i)&
10308                      +wtube*gg_tube(j,i)
10309
10310
10311
10312         enddo
10313       enddo
10314 #endif
10315 #ifdef MPI
10316       if (nfgtasks.gt.1) then
10317       time00=MPI_Wtime()
10318 #ifdef DEBUG
10319       write (iout,*) "gradbufc before allreduce"
10320       do i=1,nres
10321         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10322       enddo
10323       call flush(iout)
10324 #endif
10325       do i=0,nres
10326         do j=1,3
10327           gradbufc_sum(j,i)=gradbufc(j,i)
10328         enddo
10329       enddo
10330 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10331 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10332 !      time_reduce=time_reduce+MPI_Wtime()-time00
10333 #ifdef DEBUG
10334 !      write (iout,*) "gradbufc_sum after allreduce"
10335 !      do i=1,nres
10336 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10337 !      enddo
10338 !      call flush(iout)
10339 #endif
10340 #ifdef TIMING
10341 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10342 #endif
10343       do i=0,nres
10344         do k=1,3
10345           gradbufc(k,i)=0.0d0
10346         enddo
10347       enddo
10348 #ifdef DEBUG
10349       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10350       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10351                         " jgrad_end  ",jgrad_end(i),&
10352                         i=igrad_start,igrad_end)
10353 #endif
10354 !
10355 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10356 ! do not parallelize this part.
10357 !
10358 !      do i=igrad_start,igrad_end
10359 !        do j=jgrad_start(i),jgrad_end(i)
10360 !          do k=1,3
10361 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10362 !          enddo
10363 !        enddo
10364 !      enddo
10365       do j=1,3
10366         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10367       enddo
10368       do i=nres-2,-1,-1
10369         do j=1,3
10370           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10371         enddo
10372       enddo
10373 #ifdef DEBUG
10374       write (iout,*) "gradbufc after summing"
10375       do i=1,nres
10376         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10377       enddo
10378       call flush(iout)
10379 #endif
10380       else
10381 #endif
10382 !el#define DEBUG
10383 #ifdef DEBUG
10384       write (iout,*) "gradbufc"
10385       do i=1,nres
10386         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10387       enddo
10388       call flush(iout)
10389 #endif
10390 !el#undef DEBUG
10391       do i=-1,nres
10392         do j=1,3
10393           gradbufc_sum(j,i)=gradbufc(j,i)
10394           gradbufc(j,i)=0.0d0
10395         enddo
10396       enddo
10397       do j=1,3
10398         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10399       enddo
10400       do i=nres-2,-1,-1
10401         do j=1,3
10402           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10403         enddo
10404       enddo
10405 !      do i=nnt,nres-1
10406 !        do k=1,3
10407 !          gradbufc(k,i)=0.0d0
10408 !        enddo
10409 !        do j=i+1,nres
10410 !          do k=1,3
10411 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10412 !          enddo
10413 !        enddo
10414 !      enddo
10415 !el#define DEBUG
10416 #ifdef DEBUG
10417       write (iout,*) "gradbufc after summing"
10418       do i=1,nres
10419         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10420       enddo
10421       call flush(iout)
10422 #endif
10423 !el#undef DEBUG
10424 #ifdef MPI
10425       endif
10426 #endif
10427       do k=1,3
10428         gradbufc(k,nres)=0.0d0
10429       enddo
10430 !el----------------
10431 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10432 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10433 !el-----------------
10434       do i=-1,nct
10435         do j=1,3
10436 #ifdef SPLITELE
10437           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10438                       wel_loc*gel_loc(j,i)+ &
10439                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10440                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10441                       wel_loc*gel_loc_long(j,i)+ &
10442                       wcorr*gradcorr_long(j,i)+ &
10443                       wcorr5*gradcorr5_long(j,i)+ &
10444                       wcorr6*gradcorr6_long(j,i)+ &
10445                       wturn6*gcorr6_turn_long(j,i))+ &
10446                       wbond*gradb(j,i)+ &
10447                       wcorr*gradcorr(j,i)+ &
10448                       wturn3*gcorr3_turn(j,i)+ &
10449                       wturn4*gcorr4_turn(j,i)+ &
10450                       wcorr5*gradcorr5(j,i)+ &
10451                       wcorr6*gradcorr6(j,i)+ &
10452                       wturn6*gcorr6_turn(j,i)+ &
10453                       wsccor*gsccorc(j,i) &
10454                      +wscloc*gscloc(j,i)  &
10455                      +wliptran*gliptranc(j,i) &
10456                      +gradafm(j,i) &
10457                      +welec*gshieldc(j,i) &
10458                      +welec*gshieldc_loc(j,i) &
10459                      +wcorr*gshieldc_ec(j,i) &
10460                      +wcorr*gshieldc_loc_ec(j,i) &
10461                      +wturn3*gshieldc_t3(j,i) &
10462                      +wturn3*gshieldc_loc_t3(j,i) &
10463                      +wturn4*gshieldc_t4(j,i) &
10464                      +wturn4*gshieldc_loc_t4(j,i) &
10465                      +wel_loc*gshieldc_ll(j,i) &
10466                      +wel_loc*gshieldc_loc_ll(j,i) &
10467                      +wtube*gg_tube(j,i)
10468
10469
10470 #else
10471           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10472                       wel_loc*gel_loc(j,i)+ &
10473                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10474                       welec*gelc_long(j,i)+ &
10475                       wel_loc*gel_loc_long(j,i)+ &
10476 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10477                       wcorr5*gradcorr5_long(j,i)+ &
10478                       wcorr6*gradcorr6_long(j,i)+ &
10479                       wturn6*gcorr6_turn_long(j,i))+ &
10480                       wbond*gradb(j,i)+ &
10481                       wcorr*gradcorr(j,i)+ &
10482                       wturn3*gcorr3_turn(j,i)+ &
10483                       wturn4*gcorr4_turn(j,i)+ &
10484                       wcorr5*gradcorr5(j,i)+ &
10485                       wcorr6*gradcorr6(j,i)+ &
10486                       wturn6*gcorr6_turn(j,i)+ &
10487                       wsccor*gsccorc(j,i) &
10488                      +wscloc*gscloc(j,i) &
10489                      +gradafm(j,i) &
10490                      +wliptran*gliptranc(j,i) &
10491                      +welec*gshieldc(j,i) &
10492                      +welec*gshieldc_loc(j,) &
10493                      +wcorr*gshieldc_ec(j,i) &
10494                      +wcorr*gshieldc_loc_ec(j,i) &
10495                      +wturn3*gshieldc_t3(j,i) &
10496                      +wturn3*gshieldc_loc_t3(j,i) &
10497                      +wturn4*gshieldc_t4(j,i) &
10498                      +wturn4*gshieldc_loc_t4(j,i) &
10499                      +wel_loc*gshieldc_ll(j,i) &
10500                      +wel_loc*gshieldc_loc_ll(j,i) &
10501                      +wtube*gg_tube(j,i)
10502
10503
10504
10505 #endif
10506           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10507                         wbond*gradbx(j,i)+ &
10508                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10509                         wsccor*gsccorx(j,i) &
10510                        +wscloc*gsclocx(j,i) &
10511                        +wliptran*gliptranx(j,i) &
10512                        +welec*gshieldx(j,i)     &
10513                        +wcorr*gshieldx_ec(j,i)  &
10514                        +wturn3*gshieldx_t3(j,i) &
10515                        +wturn4*gshieldx_t4(j,i) &
10516                        +wel_loc*gshieldx_ll(j,i)&
10517                        +wtube*gg_tube_sc(j,i)
10518
10519
10520         enddo
10521       enddo
10522 #ifdef DEBUG
10523       write (iout,*) "gloc before adding corr"
10524       do i=1,4*nres
10525         write (iout,*) i,gloc(i,icg)
10526       enddo
10527 #endif
10528       do i=1,nres-3
10529         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10530          +wcorr5*g_corr5_loc(i) &
10531          +wcorr6*g_corr6_loc(i) &
10532          +wturn4*gel_loc_turn4(i) &
10533          +wturn3*gel_loc_turn3(i) &
10534          +wturn6*gel_loc_turn6(i) &
10535          +wel_loc*gel_loc_loc(i)
10536       enddo
10537 #ifdef DEBUG
10538       write (iout,*) "gloc after adding corr"
10539       do i=1,4*nres
10540         write (iout,*) i,gloc(i,icg)
10541       enddo
10542 #endif
10543 #ifdef MPI
10544       if (nfgtasks.gt.1) then
10545         do j=1,3
10546           do i=1,nres
10547             gradbufc(j,i)=gradc(j,i,icg)
10548             gradbufx(j,i)=gradx(j,i,icg)
10549           enddo
10550         enddo
10551         do i=1,4*nres
10552           glocbuf(i)=gloc(i,icg)
10553         enddo
10554 !#define DEBUG
10555 #ifdef DEBUG
10556       write (iout,*) "gloc_sc before reduce"
10557       do i=1,nres
10558        do j=1,1
10559         write (iout,*) i,j,gloc_sc(j,i,icg)
10560        enddo
10561       enddo
10562 #endif
10563 !#undef DEBUG
10564         do i=1,nres
10565          do j=1,3
10566           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10567          enddo
10568         enddo
10569         time00=MPI_Wtime()
10570         call MPI_Barrier(FG_COMM,IERR)
10571         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10572         time00=MPI_Wtime()
10573         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10574           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10575         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
10576           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10577         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10578           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10579         time_reduce=time_reduce+MPI_Wtime()-time00
10580         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10581           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10582         time_reduce=time_reduce+MPI_Wtime()-time00
10583 !#define DEBUG
10584 #ifdef DEBUG
10585       write (iout,*) "gloc_sc after reduce"
10586       do i=1,nres
10587        do j=1,1
10588         write (iout,*) i,j,gloc_sc(j,i,icg)
10589        enddo
10590       enddo
10591 #endif
10592 !#undef DEBUG
10593 #ifdef DEBUG
10594       write (iout,*) "gloc after reduce"
10595       do i=1,4*nres
10596         write (iout,*) i,gloc(i,icg)
10597       enddo
10598 #endif
10599       endif
10600 #endif
10601       if (gnorm_check) then
10602 !
10603 ! Compute the maximum elements of the gradient
10604 !
10605       gvdwc_max=0.0d0
10606       gvdwc_scp_max=0.0d0
10607       gelc_max=0.0d0
10608       gvdwpp_max=0.0d0
10609       gradb_max=0.0d0
10610       ghpbc_max=0.0d0
10611       gradcorr_max=0.0d0
10612       gel_loc_max=0.0d0
10613       gcorr3_turn_max=0.0d0
10614       gcorr4_turn_max=0.0d0
10615       gradcorr5_max=0.0d0
10616       gradcorr6_max=0.0d0
10617       gcorr6_turn_max=0.0d0
10618       gsccorc_max=0.0d0
10619       gscloc_max=0.0d0
10620       gvdwx_max=0.0d0
10621       gradx_scp_max=0.0d0
10622       ghpbx_max=0.0d0
10623       gradxorr_max=0.0d0
10624       gsccorx_max=0.0d0
10625       gsclocx_max=0.0d0
10626       do i=1,nct
10627         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10628         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10629         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10630         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10631          gvdwc_scp_max=gvdwc_scp_norm
10632         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10633         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10634         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10635         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10636         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10637         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10638         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10639         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10640         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10641         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10642         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10643         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10644         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10645           gcorr3_turn(1,i)))
10646         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10647           gcorr3_turn_max=gcorr3_turn_norm
10648         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10649           gcorr4_turn(1,i)))
10650         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10651           gcorr4_turn_max=gcorr4_turn_norm
10652         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10653         if (gradcorr5_norm.gt.gradcorr5_max) &
10654           gradcorr5_max=gradcorr5_norm
10655         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10656         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10657         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10658           gcorr6_turn(1,i)))
10659         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10660           gcorr6_turn_max=gcorr6_turn_norm
10661         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
10662         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
10663         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
10664         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
10665         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
10666         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
10667         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
10668         if (gradx_scp_norm.gt.gradx_scp_max) &
10669           gradx_scp_max=gradx_scp_norm
10670         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
10671         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
10672         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
10673         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
10674         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
10675         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
10676         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
10677         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
10678       enddo
10679       if (gradout) then
10680 #ifdef AIX
10681         open(istat,file=statname,position="append")
10682 #else
10683         open(istat,file=statname,access="append")
10684 #endif
10685         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
10686            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
10687            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
10688            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
10689            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
10690            gsccorx_max,gsclocx_max
10691         close(istat)
10692         if (gvdwc_max.gt.1.0d4) then
10693           write (iout,*) "gvdwc gvdwx gradb gradbx"
10694           do i=nnt,nct
10695             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
10696               gradb(j,i),gradbx(j,i),j=1,3)
10697           enddo
10698           call pdbout(0.0d0,'cipiszcze',iout)
10699           call flush(iout)
10700         endif
10701       endif
10702       endif
10703 !el#define DEBUG
10704 #ifdef DEBUG
10705       write (iout,*) "gradc gradx gloc"
10706       do i=1,nres
10707         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
10708          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
10709       enddo
10710 #endif
10711 !el#undef DEBUG
10712 #ifdef TIMING
10713       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
10714 #endif
10715       return
10716       end subroutine sum_gradient
10717 !-----------------------------------------------------------------------------
10718       subroutine sc_grad
10719 !      implicit real*8 (a-h,o-z)
10720       use calc_data
10721 !      include 'DIMENSIONS'
10722 !      include 'COMMON.CHAIN'
10723 !      include 'COMMON.DERIV'
10724 !      include 'COMMON.CALC'
10725 !      include 'COMMON.IOUNITS'
10726       real(kind=8), dimension(3) :: dcosom1,dcosom2
10727
10728       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
10729       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
10730       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
10731            -2.0D0*alf12*eps3der+sigder*sigsq_om12
10732 ! diagnostics only
10733 !      eom1=0.0d0
10734 !      eom2=0.0d0
10735 !      eom12=evdwij*eps1_om12
10736 ! end diagnostics
10737 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
10738 !       " sigder",sigder
10739 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
10740 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
10741 !C      print *,sss_ele_cut,'in sc_grad'
10742       do k=1,3
10743         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
10744         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
10745       enddo
10746       do k=1,3
10747         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
10748 !C      print *,'gg',k,gg(k)
10749        enddo
10750 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
10751 !      write (iout,*) "gg",(gg(k),k=1,3)
10752       do k=1,3
10753         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
10754                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10755                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
10756                   *sss_ele_cut
10757
10758         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
10759                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10760                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
10761                   *sss_ele_cut
10762
10763 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10764 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
10765 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10766 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
10767       enddo
10768 !
10769 ! Calculate the components of the gradient in DC and X
10770 !
10771 !grad      do k=i,j-1
10772 !grad        do l=1,3
10773 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
10774 !grad        enddo
10775 !grad      enddo
10776       do l=1,3
10777         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
10778         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
10779       enddo
10780       return
10781       end subroutine sc_grad
10782 #ifdef CRYST_THETA
10783 !-----------------------------------------------------------------------------
10784       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
10785
10786       use comm_calcthet
10787 !      implicit real*8 (a-h,o-z)
10788 !      include 'DIMENSIONS'
10789 !      include 'COMMON.LOCAL'
10790 !      include 'COMMON.IOUNITS'
10791 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
10792 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10793 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
10794       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
10795       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
10796 !el      integer :: it
10797 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
10798 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10799 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
10800 !el local variables
10801
10802       delthec=thetai-thet_pred_mean
10803       delthe0=thetai-theta0i
10804 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
10805       t3 = thetai-thet_pred_mean
10806       t6 = t3**2
10807       t9 = term1
10808       t12 = t3*sigcsq
10809       t14 = t12+t6*sigsqtc
10810       t16 = 1.0d0
10811       t21 = thetai-theta0i
10812       t23 = t21**2
10813       t26 = term2
10814       t27 = t21*t26
10815       t32 = termexp
10816       t40 = t32**2
10817       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
10818        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
10819        *(-t12*t9-ak*sig0inv*t27)
10820       return
10821       end subroutine mixder
10822 #endif
10823 !-----------------------------------------------------------------------------
10824 ! cartder.F
10825 !-----------------------------------------------------------------------------
10826       subroutine cartder
10827 !-----------------------------------------------------------------------------
10828 ! This subroutine calculates the derivatives of the consecutive virtual
10829 ! bond vectors and the SC vectors in the virtual-bond angles theta and
10830 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
10831 ! in the angles alpha and omega, describing the location of a side chain
10832 ! in its local coordinate system.
10833 !
10834 ! The derivatives are stored in the following arrays:
10835 !
10836 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
10837 ! The structure is as follows:
10838 !
10839 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
10840 ! 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)
10841 !         . . . . . . . . . . . .  . . . . . .
10842 ! 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)
10843 !                          .
10844 !                          .
10845 !                          .
10846 ! 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)
10847 !
10848 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
10849 ! The structure is same as above.
10850 !
10851 ! DCDS - the derivatives of the side chain vectors in the local spherical
10852 ! andgles alph and omega:
10853 !
10854 ! 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)
10855 ! 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)
10856 !                          .
10857 !                          .
10858 !                          .
10859 ! 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)
10860 !
10861 ! Version of March '95, based on an early version of November '91.
10862 !
10863 !**********************************************************************
10864 !      implicit real*8 (a-h,o-z)
10865 !      include 'DIMENSIONS'
10866 !      include 'COMMON.VAR'
10867 !      include 'COMMON.CHAIN'
10868 !      include 'COMMON.DERIV'
10869 !      include 'COMMON.GEO'
10870 !      include 'COMMON.LOCAL'
10871 !      include 'COMMON.INTERACT'
10872       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
10873       real(kind=8),dimension(3,3) :: dp,temp
10874 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
10875       real(kind=8),dimension(3) :: xx,xx1
10876 !el local variables
10877       integer :: i,k,l,j,m,ind,ind1,jjj
10878       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
10879                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
10880                  sint2,xp,yp,xxp,yyp,zzp,dj
10881
10882 !      common /przechowalnia/ fromto
10883       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
10884 ! get the position of the jth ijth fragment of the chain coordinate system
10885 ! in the fromto array.
10886 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
10887 !
10888 !      maxdim=(nres-1)*(nres-2)/2
10889 !      allocate(dcdv(6,maxdim),dxds(6,nres))
10890 ! calculate the derivatives of transformation matrix elements in theta
10891 !
10892
10893 !el      call flush(iout) !el
10894       do i=1,nres-2
10895         rdt(1,1,i)=-rt(1,2,i)
10896         rdt(1,2,i)= rt(1,1,i)
10897         rdt(1,3,i)= 0.0d0
10898         rdt(2,1,i)=-rt(2,2,i)
10899         rdt(2,2,i)= rt(2,1,i)
10900         rdt(2,3,i)= 0.0d0
10901         rdt(3,1,i)=-rt(3,2,i)
10902         rdt(3,2,i)= rt(3,1,i)
10903         rdt(3,3,i)= 0.0d0
10904       enddo
10905 !
10906 ! derivatives in phi
10907 !
10908       do i=2,nres-2
10909         drt(1,1,i)= 0.0d0
10910         drt(1,2,i)= 0.0d0
10911         drt(1,3,i)= 0.0d0
10912         drt(2,1,i)= rt(3,1,i)
10913         drt(2,2,i)= rt(3,2,i)
10914         drt(2,3,i)= rt(3,3,i)
10915         drt(3,1,i)=-rt(2,1,i)
10916         drt(3,2,i)=-rt(2,2,i)
10917         drt(3,3,i)=-rt(2,3,i)
10918       enddo
10919 !
10920 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
10921 !
10922       do i=2,nres-2
10923         ind=indmat(i,i+1)
10924         do k=1,3
10925           do l=1,3
10926             temp(k,l)=rt(k,l,i)
10927           enddo
10928         enddo
10929         do k=1,3
10930           do l=1,3
10931             fromto(k,l,ind)=temp(k,l)
10932           enddo
10933         enddo
10934         do j=i+1,nres-2
10935           ind=indmat(i,j+1)
10936           do k=1,3
10937             do l=1,3
10938               dpkl=0.0d0
10939               do m=1,3
10940                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
10941               enddo
10942               dp(k,l)=dpkl
10943               fromto(k,l,ind)=dpkl
10944             enddo
10945           enddo
10946           do k=1,3
10947             do l=1,3
10948               temp(k,l)=dp(k,l)
10949             enddo
10950           enddo
10951         enddo
10952       enddo
10953 !
10954 ! Calculate derivatives.
10955 !
10956       ind1=0
10957       do i=1,nres-2
10958         ind1=ind1+1
10959 !
10960 ! Derivatives of DC(i+1) in theta(i+2)
10961 !
10962         do j=1,3
10963           do k=1,2
10964             dpjk=0.0D0
10965             do l=1,3
10966               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
10967             enddo
10968             dp(j,k)=dpjk
10969             prordt(j,k,i)=dp(j,k)
10970           enddo
10971           dp(j,3)=0.0D0
10972           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
10973         enddo
10974 !
10975 ! Derivatives of SC(i+1) in theta(i+2)
10976 !
10977         xx1(1)=-0.5D0*xloc(2,i+1)
10978         xx1(2)= 0.5D0*xloc(1,i+1)
10979         do j=1,3
10980           xj=0.0D0
10981           do k=1,2
10982             xj=xj+r(j,k,i)*xx1(k)
10983           enddo
10984           xx(j)=xj
10985         enddo
10986         do j=1,3
10987           rj=0.0D0
10988           do k=1,3
10989             rj=rj+prod(j,k,i)*xx(k)
10990           enddo
10991           dxdv(j,ind1)=rj
10992         enddo
10993 !
10994 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
10995 ! than the other off-diagonal derivatives.
10996 !
10997         do j=1,3
10998           dxoiij=0.0D0
10999           do k=1,3
11000             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11001           enddo
11002           dxdv(j,ind1+1)=dxoiij
11003         enddo
11004 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11005 !
11006 ! Derivatives of DC(i+1) in phi(i+2)
11007 !
11008         do j=1,3
11009           do k=1,3
11010             dpjk=0.0
11011             do l=2,3
11012               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11013             enddo
11014             dp(j,k)=dpjk
11015             prodrt(j,k,i)=dp(j,k)
11016           enddo
11017           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11018         enddo
11019 !
11020 ! Derivatives of SC(i+1) in phi(i+2)
11021 !
11022         xx(1)= 0.0D0
11023         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11024         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11025         do j=1,3
11026           rj=0.0D0
11027           do k=2,3
11028             rj=rj+prod(j,k,i)*xx(k)
11029           enddo
11030           dxdv(j+3,ind1)=-rj
11031         enddo
11032 !
11033 ! Derivatives of SC(i+1) in phi(i+3).
11034 !
11035         do j=1,3
11036           dxoiij=0.0D0
11037           do k=1,3
11038             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11039           enddo
11040           dxdv(j+3,ind1+1)=dxoiij
11041         enddo
11042 !
11043 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11044 ! theta(nres) and phi(i+3) thru phi(nres).
11045 !
11046         do j=i+1,nres-2
11047           ind1=ind1+1
11048           ind=indmat(i+1,j+1)
11049 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11050           do k=1,3
11051             do l=1,3
11052               tempkl=0.0D0
11053               do m=1,2
11054                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11055               enddo
11056               temp(k,l)=tempkl
11057             enddo
11058           enddo
11059 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11060 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11061 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11062 ! Derivatives of virtual-bond vectors in theta
11063           do k=1,3
11064             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11065           enddo
11066 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11067 ! Derivatives of SC vectors in theta
11068           do k=1,3
11069             dxoijk=0.0D0
11070             do l=1,3
11071               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11072             enddo
11073             dxdv(k,ind1+1)=dxoijk
11074           enddo
11075 !
11076 !--- Calculate the derivatives in phi
11077 !
11078           do k=1,3
11079             do l=1,3
11080               tempkl=0.0D0
11081               do m=1,3
11082                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11083               enddo
11084               temp(k,l)=tempkl
11085             enddo
11086           enddo
11087           do k=1,3
11088             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11089           enddo
11090           do k=1,3
11091             dxoijk=0.0D0
11092             do l=1,3
11093               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11094             enddo
11095             dxdv(k+3,ind1+1)=dxoijk
11096           enddo
11097         enddo
11098       enddo
11099 !
11100 ! Derivatives in alpha and omega:
11101 !
11102       do i=2,nres-1
11103 !       dsci=dsc(itype(i))
11104         dsci=vbld(i+nres)
11105 #ifdef OSF
11106         alphi=alph(i)
11107         omegi=omeg(i)
11108         if(alphi.ne.alphi) alphi=100.0
11109         if(omegi.ne.omegi) omegi=-100.0
11110 #else
11111         alphi=alph(i)
11112         omegi=omeg(i)
11113 #endif
11114 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11115         cosalphi=dcos(alphi)
11116         sinalphi=dsin(alphi)
11117         cosomegi=dcos(omegi)
11118         sinomegi=dsin(omegi)
11119         temp(1,1)=-dsci*sinalphi
11120         temp(2,1)= dsci*cosalphi*cosomegi
11121         temp(3,1)=-dsci*cosalphi*sinomegi
11122         temp(1,2)=0.0D0
11123         temp(2,2)=-dsci*sinalphi*sinomegi
11124         temp(3,2)=-dsci*sinalphi*cosomegi
11125         theta2=pi-0.5D0*theta(i+1)
11126         cost2=dcos(theta2)
11127         sint2=dsin(theta2)
11128         jjj=0
11129 !d      print *,((temp(l,k),l=1,3),k=1,2)
11130         do j=1,2
11131           xp=temp(1,j)
11132           yp=temp(2,j)
11133           xxp= xp*cost2+yp*sint2
11134           yyp=-xp*sint2+yp*cost2
11135           zzp=temp(3,j)
11136           xx(1)=xxp
11137           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11138           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11139           do k=1,3
11140             dj=0.0D0
11141             do l=1,3
11142               dj=dj+prod(k,l,i-1)*xx(l)
11143             enddo
11144             dxds(jjj+k,i)=dj
11145           enddo
11146           jjj=jjj+3
11147         enddo
11148       enddo
11149       return
11150       end subroutine cartder
11151 !-----------------------------------------------------------------------------
11152 ! checkder_p.F
11153 !-----------------------------------------------------------------------------
11154       subroutine check_cartgrad
11155 ! Check the gradient of Cartesian coordinates in internal coordinates.
11156 !      implicit real*8 (a-h,o-z)
11157 !      include 'DIMENSIONS'
11158 !      include 'COMMON.IOUNITS'
11159 !      include 'COMMON.VAR'
11160 !      include 'COMMON.CHAIN'
11161 !      include 'COMMON.GEO'
11162 !      include 'COMMON.LOCAL'
11163 !      include 'COMMON.DERIV'
11164       real(kind=8),dimension(6,nres) :: temp
11165       real(kind=8),dimension(3) :: xx,gg
11166       integer :: i,k,j,ii
11167       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11168 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11169 !
11170 ! Check the gradient of the virtual-bond and SC vectors in the internal
11171 ! coordinates.
11172 !
11173       aincr=1.0d-6
11174       aincr2=5.0d-7
11175       call cartder
11176       write (iout,'(a)') '**************** dx/dalpha'
11177       write (iout,'(a)')
11178       do i=2,nres-1
11179         alphi=alph(i)
11180         alph(i)=alph(i)+aincr
11181         do k=1,3
11182           temp(k,i)=dc(k,nres+i)
11183         enddo
11184         call chainbuild
11185         do k=1,3
11186           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11187           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11188         enddo
11189         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11190         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11191         write (iout,'(a)')
11192         alph(i)=alphi
11193         call chainbuild
11194       enddo
11195       write (iout,'(a)')
11196       write (iout,'(a)') '**************** dx/domega'
11197       write (iout,'(a)')
11198       do i=2,nres-1
11199         omegi=omeg(i)
11200         omeg(i)=omeg(i)+aincr
11201         do k=1,3
11202           temp(k,i)=dc(k,nres+i)
11203         enddo
11204         call chainbuild
11205         do k=1,3
11206           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11207           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11208                 (aincr*dabs(dxds(k+3,i))+aincr))
11209         enddo
11210         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11211             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11212         write (iout,'(a)')
11213         omeg(i)=omegi
11214         call chainbuild
11215       enddo
11216       write (iout,'(a)')
11217       write (iout,'(a)') '**************** dx/dtheta'
11218       write (iout,'(a)')
11219       do i=3,nres
11220         theti=theta(i)
11221         theta(i)=theta(i)+aincr
11222         do j=i-1,nres-1
11223           do k=1,3
11224             temp(k,j)=dc(k,nres+j)
11225           enddo
11226         enddo
11227         call chainbuild
11228         do j=i-1,nres-1
11229           ii = indmat(i-2,j)
11230 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11231           do k=1,3
11232             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11233             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11234                   (aincr*dabs(dxdv(k,ii))+aincr))
11235           enddo
11236           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11237               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11238           write(iout,'(a)')
11239         enddo
11240         write (iout,'(a)')
11241         theta(i)=theti
11242         call chainbuild
11243       enddo
11244       write (iout,'(a)') '***************** dx/dphi'
11245       write (iout,'(a)')
11246       do i=4,nres
11247         phi(i)=phi(i)+aincr
11248         do j=i-1,nres-1
11249           do k=1,3
11250             temp(k,j)=dc(k,nres+j)
11251           enddo
11252         enddo
11253         call chainbuild
11254         do j=i-1,nres-1
11255           ii = indmat(i-2,j)
11256 !         print *,'ii=',ii
11257           do k=1,3
11258             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11259             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11260                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11261           enddo
11262           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11263               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11264           write(iout,'(a)')
11265         enddo
11266         phi(i)=phi(i)-aincr
11267         call chainbuild
11268       enddo
11269       write (iout,'(a)') '****************** ddc/dtheta'
11270       do i=1,nres-2
11271         thet=theta(i+2)
11272         theta(i+2)=thet+aincr
11273         do j=i,nres
11274           do k=1,3
11275             temp(k,j)=dc(k,j)
11276           enddo
11277         enddo
11278         call chainbuild
11279         do j=i+1,nres-1
11280           ii = indmat(i,j)
11281 !         print *,'ii=',ii
11282           do k=1,3
11283             gg(k)=(dc(k,j)-temp(k,j))/aincr
11284             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11285                  (aincr*dabs(dcdv(k,ii))+aincr))
11286           enddo
11287           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11288                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11289           write (iout,'(a)')
11290         enddo
11291         do j=1,nres
11292           do k=1,3
11293             dc(k,j)=temp(k,j)
11294           enddo
11295         enddo
11296         theta(i+2)=thet
11297       enddo
11298       write (iout,'(a)') '******************* ddc/dphi'
11299       do i=1,nres-3
11300         phii=phi(i+3)
11301         phi(i+3)=phii+aincr
11302         do j=1,nres
11303           do k=1,3
11304             temp(k,j)=dc(k,j)
11305           enddo
11306         enddo
11307         call chainbuild
11308         do j=i+2,nres-1
11309           ii = indmat(i+1,j)
11310 !         print *,'ii=',ii
11311           do k=1,3
11312             gg(k)=(dc(k,j)-temp(k,j))/aincr
11313             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11314                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11315           enddo
11316           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11317                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11318           write (iout,'(a)')
11319         enddo
11320         do j=1,nres
11321           do k=1,3
11322             dc(k,j)=temp(k,j)
11323           enddo
11324         enddo
11325         phi(i+3)=phii
11326       enddo
11327       return
11328       end subroutine check_cartgrad
11329 !-----------------------------------------------------------------------------
11330       subroutine check_ecart
11331 ! Check the gradient of the energy in Cartesian coordinates.
11332 !     implicit real*8 (a-h,o-z)
11333 !     include 'DIMENSIONS'
11334 !     include 'COMMON.CHAIN'
11335 !     include 'COMMON.DERIV'
11336 !     include 'COMMON.IOUNITS'
11337 !     include 'COMMON.VAR'
11338 !     include 'COMMON.CONTACTS'
11339       use comm_srutu
11340 !el      integer :: icall
11341 !el      common /srutu/ icall
11342       real(kind=8),dimension(6) :: ggg
11343       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11344       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11345       real(kind=8),dimension(6,nres) :: grad_s
11346       real(kind=8),dimension(0:n_ene) :: energia,energia1
11347       integer :: uiparm(1)
11348       real(kind=8) :: urparm(1)
11349 !EL      external fdum
11350       integer :: nf,i,j,k
11351       real(kind=8) :: aincr,etot,etot1
11352       icg=1
11353       nf=0
11354       nfl=0
11355       call zerograd
11356       aincr=1.0D-5
11357       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11358       nf=0
11359       icall=0
11360       call geom_to_var(nvar,x)
11361       call etotal(energia)
11362       etot=energia(0)
11363 !el      call enerprint(energia)
11364       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11365       icall =1
11366       do i=1,nres
11367         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11368       enddo
11369       do i=1,nres
11370         do j=1,3
11371           grad_s(j,i)=gradc(j,i,icg)
11372           grad_s(j+3,i)=gradx(j,i,icg)
11373         enddo
11374       enddo
11375       call flush(iout)
11376       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11377       do i=1,nres
11378         do j=1,3
11379           xx(j)=c(j,i+nres)
11380           ddc(j)=dc(j,i)
11381           ddx(j)=dc(j,i+nres)
11382         enddo
11383         do j=1,3
11384           dc(j,i)=dc(j,i)+aincr
11385           do k=i+1,nres
11386             c(j,k)=c(j,k)+aincr
11387             c(j,k+nres)=c(j,k+nres)+aincr
11388           enddo
11389           call etotal(energia1)
11390           etot1=energia1(0)
11391           ggg(j)=(etot1-etot)/aincr
11392           dc(j,i)=ddc(j)
11393           do k=i+1,nres
11394             c(j,k)=c(j,k)-aincr
11395             c(j,k+nres)=c(j,k+nres)-aincr
11396           enddo
11397         enddo
11398         do j=1,3
11399           c(j,i+nres)=c(j,i+nres)+aincr
11400           dc(j,i+nres)=dc(j,i+nres)+aincr
11401           call etotal(energia1)
11402           etot1=energia1(0)
11403           ggg(j+3)=(etot1-etot)/aincr
11404           c(j,i+nres)=xx(j)
11405           dc(j,i+nres)=ddx(j)
11406         enddo
11407         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11408          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11409       enddo
11410       return
11411       end subroutine check_ecart
11412 #ifdef CARGRAD
11413 !-----------------------------------------------------------------------------
11414       subroutine check_ecartint
11415 ! Check the gradient of the energy in Cartesian coordinates.
11416       use io_base, only: intout
11417 !      implicit real*8 (a-h,o-z)
11418 !      include 'DIMENSIONS'
11419 !      include 'COMMON.CONTROL'
11420 !      include 'COMMON.CHAIN'
11421 !      include 'COMMON.DERIV'
11422 !      include 'COMMON.IOUNITS'
11423 !      include 'COMMON.VAR'
11424 !      include 'COMMON.CONTACTS'
11425 !      include 'COMMON.MD'
11426 !      include 'COMMON.LOCAL'
11427 !      include 'COMMON.SPLITELE'
11428       use comm_srutu
11429 !el      integer :: icall
11430 !el      common /srutu/ icall
11431       real(kind=8),dimension(6) :: ggg,ggg1
11432       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11433       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11434       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11435       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11436       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11437       real(kind=8),dimension(0:n_ene) :: energia,energia1
11438       integer :: uiparm(1)
11439       real(kind=8) :: urparm(1)
11440 !EL      external fdum
11441       integer :: i,j,k,nf
11442       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11443                    etot21,etot22
11444       r_cut=2.0d0
11445       rlambd=0.3d0
11446       icg=1
11447       nf=0
11448       nfl=0
11449       call intout
11450 !      call intcartderiv
11451 !      call checkintcartgrad
11452       call zerograd
11453       aincr=1.0D-5
11454       write(iout,*) 'Calling CHECK_ECARTINT.'
11455       nf=0
11456       icall=0
11457       write (iout,*) "Before geom_to_var"
11458       call geom_to_var(nvar,x)
11459       write (iout,*) "after geom_to_var"
11460       write (iout,*) "split_ene ",split_ene
11461       call flush(iout)
11462       if (.not.split_ene) then
11463         write(iout,*) 'Calling CHECK_ECARTINT if'
11464         call etotal(energia)
11465 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11466         etot=energia(0)
11467         write (iout,*) "etot",etot
11468         call flush(iout)
11469 !el        call enerprint(energia)
11470 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11471         call flush(iout)
11472         write (iout,*) "enter cartgrad"
11473         call flush(iout)
11474         call cartgrad
11475 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11476         write (iout,*) "exit cartgrad"
11477         call flush(iout)
11478         icall =1
11479         do i=1,nres
11480           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11481         enddo
11482         do j=1,3
11483           grad_s(j,0)=gcart(j,0)
11484         enddo
11485 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11486         do i=1,nres
11487           do j=1,3
11488             grad_s(j,i)=gcart(j,i)
11489             grad_s(j+3,i)=gxcart(j,i)
11490           enddo
11491         enddo
11492       else
11493 write(iout,*) 'Calling CHECK_ECARTIN else.'
11494 !- split gradient check
11495         call zerograd
11496         call etotal_long(energia)
11497 !el        call enerprint(energia)
11498         call flush(iout)
11499         write (iout,*) "enter cartgrad"
11500         call flush(iout)
11501         call cartgrad
11502         write (iout,*) "exit cartgrad"
11503         call flush(iout)
11504         icall =1
11505         write (iout,*) "longrange grad"
11506         do i=1,nres
11507           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11508           (gxcart(j,i),j=1,3)
11509         enddo
11510         do j=1,3
11511           grad_s(j,0)=gcart(j,0)
11512         enddo
11513         do i=1,nres
11514           do j=1,3
11515             grad_s(j,i)=gcart(j,i)
11516             grad_s(j+3,i)=gxcart(j,i)
11517           enddo
11518         enddo
11519         call zerograd
11520         call etotal_short(energia)
11521 !el        call enerprint(energia)
11522         call flush(iout)
11523         write (iout,*) "enter cartgrad"
11524         call flush(iout)
11525         call cartgrad
11526         write (iout,*) "exit cartgrad"
11527         call flush(iout)
11528         icall =1
11529         write (iout,*) "shortrange grad"
11530         do i=1,nres
11531           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11532           (gxcart(j,i),j=1,3)
11533         enddo
11534         do j=1,3
11535           grad_s1(j,0)=gcart(j,0)
11536         enddo
11537         do i=1,nres
11538           do j=1,3
11539             grad_s1(j,i)=gcart(j,i)
11540             grad_s1(j+3,i)=gxcart(j,i)
11541           enddo
11542         enddo
11543       endif
11544       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11545 !      do i=1,nres
11546       do i=nnt,nct
11547         do j=1,3
11548           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11549           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11550           ddc(j)=c(j,i)
11551           ddx(j)=c(j,i+nres)
11552           dcnorm_safe1(j)=dc_norm(j,i-1)
11553           dcnorm_safe2(j)=dc_norm(j,i)
11554           dxnorm_safe(j)=dc_norm(j,i+nres)
11555         enddo
11556         do j=1,3
11557           c(j,i)=ddc(j)+aincr
11558           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11559           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11560           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11561           dc(j,i)=c(j,i+1)-c(j,i)
11562           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11563           call int_from_cart1(.false.)
11564           if (.not.split_ene) then
11565             call etotal(energia1)
11566             etot1=energia1(0)
11567             write (iout,*) "ij",i,j," etot1",etot1
11568           else
11569 !- split gradient
11570             call etotal_long(energia1)
11571             etot11=energia1(0)
11572             call etotal_short(energia1)
11573             etot12=energia1(0)
11574           endif
11575 !- end split gradient
11576 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11577           c(j,i)=ddc(j)-aincr
11578           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11579           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11580           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11581           dc(j,i)=c(j,i+1)-c(j,i)
11582           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11583           call int_from_cart1(.false.)
11584           if (.not.split_ene) then
11585             call etotal(energia1)
11586             etot2=energia1(0)
11587             write (iout,*) "ij",i,j," etot2",etot2
11588             ggg(j)=(etot1-etot2)/(2*aincr)
11589           else
11590 !- split gradient
11591             call etotal_long(energia1)
11592             etot21=energia1(0)
11593             ggg(j)=(etot11-etot21)/(2*aincr)
11594             call etotal_short(energia1)
11595             etot22=energia1(0)
11596             ggg1(j)=(etot12-etot22)/(2*aincr)
11597 !- end split gradient
11598 !            write (iout,*) "etot21",etot21," etot22",etot22
11599           endif
11600 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11601           c(j,i)=ddc(j)
11602           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11603           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11604           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11605           dc(j,i)=c(j,i+1)-c(j,i)
11606           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11607           dc_norm(j,i-1)=dcnorm_safe1(j)
11608           dc_norm(j,i)=dcnorm_safe2(j)
11609           dc_norm(j,i+nres)=dxnorm_safe(j)
11610         enddo
11611         do j=1,3
11612           c(j,i+nres)=ddx(j)+aincr
11613           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11614           call int_from_cart1(.false.)
11615           if (.not.split_ene) then
11616             call etotal(energia1)
11617             etot1=energia1(0)
11618           else
11619 !- split gradient
11620             call etotal_long(energia1)
11621             etot11=energia1(0)
11622             call etotal_short(energia1)
11623             etot12=energia1(0)
11624           endif
11625 !- end split gradient
11626           c(j,i+nres)=ddx(j)-aincr
11627           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11628           call int_from_cart1(.false.)
11629           if (.not.split_ene) then
11630             call etotal(energia1)
11631             etot2=energia1(0)
11632             ggg(j+3)=(etot1-etot2)/(2*aincr)
11633           else
11634 !- split gradient
11635             call etotal_long(energia1)
11636             etot21=energia1(0)
11637             ggg(j+3)=(etot11-etot21)/(2*aincr)
11638             call etotal_short(energia1)
11639             etot22=energia1(0)
11640             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11641 !- end split gradient
11642           endif
11643 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11644           c(j,i+nres)=ddx(j)
11645           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11646           dc_norm(j,i+nres)=dxnorm_safe(j)
11647           call int_from_cart1(.false.)
11648         enddo
11649         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11650          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11651         if (split_ene) then
11652           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11653          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11654          k=1,6)
11655          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11656          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11657          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11658         endif
11659       enddo
11660       return
11661       end subroutine check_ecartint
11662 #else
11663 !-----------------------------------------------------------------------------
11664       subroutine check_ecartint
11665 ! Check the gradient of the energy in Cartesian coordinates.
11666       use io_base, only: intout
11667 !      implicit real*8 (a-h,o-z)
11668 !      include 'DIMENSIONS'
11669 !      include 'COMMON.CONTROL'
11670 !      include 'COMMON.CHAIN'
11671 !      include 'COMMON.DERIV'
11672 !      include 'COMMON.IOUNITS'
11673 !      include 'COMMON.VAR'
11674 !      include 'COMMON.CONTACTS'
11675 !      include 'COMMON.MD'
11676 !      include 'COMMON.LOCAL'
11677 !      include 'COMMON.SPLITELE'
11678       use comm_srutu
11679 !el      integer :: icall
11680 !el      common /srutu/ icall
11681       real(kind=8),dimension(6) :: ggg,ggg1
11682       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11683       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11684       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
11685       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11686       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11687       real(kind=8),dimension(0:n_ene) :: energia,energia1
11688       integer :: uiparm(1)
11689       real(kind=8) :: urparm(1)
11690 !EL      external fdum
11691       integer :: i,j,k,nf
11692       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11693                    etot21,etot22
11694       r_cut=2.0d0
11695       rlambd=0.3d0
11696       icg=1
11697       nf=0
11698       nfl=0
11699       call intout
11700 !      call intcartderiv
11701 !      call checkintcartgrad
11702       call zerograd
11703       aincr=2.0D-5
11704       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
11705       nf=0
11706       icall=0
11707       call geom_to_var(nvar,x)
11708       if (.not.split_ene) then
11709         call etotal(energia)
11710         etot=energia(0)
11711 !el        call enerprint(energia)
11712         call flush(iout)
11713         write (iout,*) "enter cartgrad"
11714         call flush(iout)
11715         call cartgrad
11716         write (iout,*) "exit cartgrad"
11717         call flush(iout)
11718         icall =1
11719         do i=1,nres
11720           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11721         enddo
11722         do j=1,3
11723           grad_s(j,0)=gcart(j,0)
11724         enddo
11725         do i=1,nres
11726           do j=1,3
11727             grad_s(j,i)=gcart(j,i)
11728             grad_s(j+3,i)=gxcart(j,i)
11729           enddo
11730         enddo
11731       else
11732 !- split gradient check
11733         call zerograd
11734         call etotal_long(energia)
11735 !el        call enerprint(energia)
11736         call flush(iout)
11737         write (iout,*) "enter cartgrad"
11738         call flush(iout)
11739         call cartgrad
11740         write (iout,*) "exit cartgrad"
11741         call flush(iout)
11742         icall =1
11743         write (iout,*) "longrange grad"
11744         do i=1,nres
11745           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11746           (gxcart(j,i),j=1,3)
11747         enddo
11748         do j=1,3
11749           grad_s(j,0)=gcart(j,0)
11750         enddo
11751         do i=1,nres
11752           do j=1,3
11753             grad_s(j,i)=gcart(j,i)
11754             grad_s(j+3,i)=gxcart(j,i)
11755           enddo
11756         enddo
11757         call zerograd
11758         call etotal_short(energia)
11759 !el        call enerprint(energia)
11760         call flush(iout)
11761         write (iout,*) "enter cartgrad"
11762         call flush(iout)
11763         call cartgrad
11764         write (iout,*) "exit cartgrad"
11765         call flush(iout)
11766         icall =1
11767         write (iout,*) "shortrange grad"
11768         do i=1,nres
11769           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11770           (gxcart(j,i),j=1,3)
11771         enddo
11772         do j=1,3
11773           grad_s1(j,0)=gcart(j,0)
11774         enddo
11775         do i=1,nres
11776           do j=1,3
11777             grad_s1(j,i)=gcart(j,i)
11778             grad_s1(j+3,i)=gxcart(j,i)
11779           enddo
11780         enddo
11781       endif
11782       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11783       do i=0,nres
11784         do j=1,3
11785           xx(j)=c(j,i+nres)
11786           ddc(j)=dc(j,i)
11787           ddx(j)=dc(j,i+nres)
11788           do k=1,3
11789             dcnorm_safe(k)=dc_norm(k,i)
11790             dxnorm_safe(k)=dc_norm(k,i+nres)
11791           enddo
11792         enddo
11793         do j=1,3
11794           dc(j,i)=ddc(j)+aincr
11795           call chainbuild_cart
11796 #ifdef MPI
11797 ! Broadcast the order to compute internal coordinates to the slaves.
11798 !          if (nfgtasks.gt.1)
11799 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
11800 #endif
11801 !          call int_from_cart1(.false.)
11802           if (.not.split_ene) then
11803             call etotal(energia1)
11804             etot1=energia1(0)
11805           else
11806 !- split gradient
11807             call etotal_long(energia1)
11808             etot11=energia1(0)
11809             call etotal_short(energia1)
11810             etot12=energia1(0)
11811 !            write (iout,*) "etot11",etot11," etot12",etot12
11812           endif
11813 !- end split gradient
11814 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11815           dc(j,i)=ddc(j)-aincr
11816           call chainbuild_cart
11817 !          call int_from_cart1(.false.)
11818           if (.not.split_ene) then
11819             call etotal(energia1)
11820             etot2=energia1(0)
11821             ggg(j)=(etot1-etot2)/(2*aincr)
11822           else
11823 !- split gradient
11824             call etotal_long(energia1)
11825             etot21=energia1(0)
11826             ggg(j)=(etot11-etot21)/(2*aincr)
11827             call etotal_short(energia1)
11828             etot22=energia1(0)
11829             ggg1(j)=(etot12-etot22)/(2*aincr)
11830 !- end split gradient
11831 !            write (iout,*) "etot21",etot21," etot22",etot22
11832           endif
11833 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11834           dc(j,i)=ddc(j)
11835           call chainbuild_cart
11836         enddo
11837         do j=1,3
11838           dc(j,i+nres)=ddx(j)+aincr
11839           call chainbuild_cart
11840 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
11841 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11842 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11843 !          write (iout,*) "dxnormnorm",dsqrt(
11844 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11845 !          write (iout,*) "dxnormnormsafe",dsqrt(
11846 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11847 !          write (iout,*)
11848           if (.not.split_ene) then
11849             call etotal(energia1)
11850             etot1=energia1(0)
11851           else
11852 !- split gradient
11853             call etotal_long(energia1)
11854             etot11=energia1(0)
11855             call etotal_short(energia1)
11856             etot12=energia1(0)
11857           endif
11858 !- end split gradient
11859 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11860           dc(j,i+nres)=ddx(j)-aincr
11861           call chainbuild_cart
11862 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
11863 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11864 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11865 !          write (iout,*)
11866 !          write (iout,*) "dxnormnorm",dsqrt(
11867 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11868 !          write (iout,*) "dxnormnormsafe",dsqrt(
11869 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11870           if (.not.split_ene) then
11871             call etotal(energia1)
11872             etot2=energia1(0)
11873             ggg(j+3)=(etot1-etot2)/(2*aincr)
11874           else
11875 !- split gradient
11876             call etotal_long(energia1)
11877             etot21=energia1(0)
11878             ggg(j+3)=(etot11-etot21)/(2*aincr)
11879             call etotal_short(energia1)
11880             etot22=energia1(0)
11881             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11882 !- end split gradient
11883           endif
11884 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11885           dc(j,i+nres)=ddx(j)
11886           call chainbuild_cart
11887         enddo
11888         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11889          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11890         if (split_ene) then
11891           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11892          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11893          k=1,6)
11894          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11895          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11896          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11897         endif
11898       enddo
11899       return
11900       end subroutine check_ecartint
11901 #endif
11902 !-----------------------------------------------------------------------------
11903       subroutine check_eint
11904 ! Check the gradient of energy in internal coordinates.
11905 !      implicit real*8 (a-h,o-z)
11906 !      include 'DIMENSIONS'
11907 !      include 'COMMON.CHAIN'
11908 !      include 'COMMON.DERIV'
11909 !      include 'COMMON.IOUNITS'
11910 !      include 'COMMON.VAR'
11911 !      include 'COMMON.GEO'
11912       use comm_srutu
11913 !el      integer :: icall
11914 !el      common /srutu/ icall
11915       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
11916       integer :: uiparm(1)
11917       real(kind=8) :: urparm(1)
11918       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
11919       character(len=6) :: key
11920 !EL      external fdum
11921       integer :: i,ii,nf
11922       real(kind=8) :: xi,aincr,etot,etot1,etot2
11923       call zerograd
11924       aincr=1.0D-7
11925       print '(a)','Calling CHECK_INT.'
11926       nf=0
11927       nfl=0
11928       icg=1
11929       call geom_to_var(nvar,x)
11930       call var_to_geom(nvar,x)
11931       call chainbuild
11932       icall=1
11933       print *,'ICG=',ICG
11934       call etotal(energia)
11935       etot = energia(0)
11936 !el      call enerprint(energia)
11937       print *,'ICG=',ICG
11938 #ifdef MPL
11939       if (MyID.ne.BossID) then
11940         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
11941         nf=x(nvar+1)
11942         nfl=x(nvar+2)
11943         icg=x(nvar+3)
11944       endif
11945 #endif
11946       nf=1
11947       nfl=3
11948 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
11949       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
11950 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
11951       icall=1
11952       do i=1,nvar
11953         xi=x(i)
11954         x(i)=xi-0.5D0*aincr
11955         call var_to_geom(nvar,x)
11956         call chainbuild
11957         call etotal(energia1)
11958         etot1=energia1(0)
11959         x(i)=xi+0.5D0*aincr
11960         call var_to_geom(nvar,x)
11961         call chainbuild
11962         call etotal(energia2)
11963         etot2=energia2(0)
11964         gg(i)=(etot2-etot1)/aincr
11965         write (iout,*) i,etot1,etot2
11966         x(i)=xi
11967       enddo
11968       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
11969           '     RelDiff*100% '
11970       do i=1,nvar
11971         if (i.le.nphi) then
11972           ii=i
11973           key = ' phi'
11974         else if (i.le.nphi+ntheta) then
11975           ii=i-nphi
11976           key=' theta'
11977         else if (i.le.nphi+ntheta+nside) then
11978            ii=i-(nphi+ntheta)
11979            key=' alpha'
11980         else
11981            ii=i-(nphi+ntheta+nside)
11982            key=' omega'
11983         endif
11984         write (iout,'(i3,a,i3,3(1pd16.6))') &
11985        i,key,ii,gg(i),gana(i),&
11986        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
11987       enddo
11988       return
11989       end subroutine check_eint
11990 !-----------------------------------------------------------------------------
11991 ! econstr_local.F
11992 !-----------------------------------------------------------------------------
11993       subroutine Econstr_back
11994 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
11995 !      implicit real*8 (a-h,o-z)
11996 !      include 'DIMENSIONS'
11997 !      include 'COMMON.CONTROL'
11998 !      include 'COMMON.VAR'
11999 !      include 'COMMON.MD'
12000       use MD_data
12001 !#ifndef LANG0
12002 !      include 'COMMON.LANGEVIN'
12003 !#else
12004 !      include 'COMMON.LANGEVIN.lang0'
12005 !#endif
12006 !      include 'COMMON.CHAIN'
12007 !      include 'COMMON.DERIV'
12008 !      include 'COMMON.GEO'
12009 !      include 'COMMON.LOCAL'
12010 !      include 'COMMON.INTERACT'
12011 !      include 'COMMON.IOUNITS'
12012 !      include 'COMMON.NAMES'
12013 !      include 'COMMON.TIME1'
12014       integer :: i,j,ii,k
12015       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12016
12017       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12018       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12019       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12020
12021       Uconst_back=0.0d0
12022       do i=1,nres
12023         dutheta(i)=0.0d0
12024         dugamma(i)=0.0d0
12025         do j=1,3
12026           duscdiff(j,i)=0.0d0
12027           duscdiffx(j,i)=0.0d0
12028         enddo
12029       enddo
12030       do i=1,nfrag_back
12031         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12032 !
12033 ! Deviations from theta angles
12034 !
12035         utheta_i=0.0d0
12036         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12037           dtheta_i=theta(j)-thetaref(j)
12038           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12039           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12040         enddo
12041         utheta(i)=utheta_i/(ii-1)
12042 !
12043 ! Deviations from gamma angles
12044 !
12045         ugamma_i=0.0d0
12046         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12047           dgamma_i=pinorm(phi(j)-phiref(j))
12048 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12049           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12050           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12051 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12052         enddo
12053         ugamma(i)=ugamma_i/(ii-2)
12054 !
12055 ! Deviations from local SC geometry
12056 !
12057         uscdiff(i)=0.0d0
12058         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12059           dxx=xxtab(j)-xxref(j)
12060           dyy=yytab(j)-yyref(j)
12061           dzz=zztab(j)-zzref(j)
12062           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12063           do k=1,3
12064             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12065              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12066              (ii-1)
12067             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12068              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12069              (ii-1)
12070             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12071            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12072             /(ii-1)
12073           enddo
12074 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12075 !     &      xxref(j),yyref(j),zzref(j)
12076         enddo
12077         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12078 !        write (iout,*) i," uscdiff",uscdiff(i)
12079 !
12080 ! Put together deviations from local geometry
12081 !
12082         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12083           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12084 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12085 !     &   " uconst_back",uconst_back
12086         utheta(i)=dsqrt(utheta(i))
12087         ugamma(i)=dsqrt(ugamma(i))
12088         uscdiff(i)=dsqrt(uscdiff(i))
12089       enddo
12090       return
12091       end subroutine Econstr_back
12092 !-----------------------------------------------------------------------------
12093 ! energy_p_new-sep_barrier.F
12094 !-----------------------------------------------------------------------------
12095       real(kind=8) function sscale(r)
12096 !      include "COMMON.SPLITELE"
12097       real(kind=8) :: r,gamm
12098       if(r.lt.r_cut-rlamb) then
12099         sscale=1.0d0
12100       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12101         gamm=(r-(r_cut-rlamb))/rlamb
12102         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12103       else
12104         sscale=0d0
12105       endif
12106       return
12107       end function sscale
12108       real(kind=8) function sscale_grad(r)
12109 !      include "COMMON.SPLITELE"
12110       real(kind=8) :: r,gamm
12111       if(r.lt.r_cut-rlamb) then
12112         sscale_grad=0.0d0
12113       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12114         gamm=(r-(r_cut-rlamb))/rlamb
12115         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12116       else
12117         sscale_grad=0d0
12118       endif
12119       return
12120       end function sscale_grad
12121
12122 !!!!!!!!!! PBCSCALE
12123       real(kind=8) function sscale_ele(r)
12124 !      include "COMMON.SPLITELE"
12125       real(kind=8) :: r,gamm
12126       if(r.lt.r_cut_ele-rlamb_ele) then
12127         sscale_ele=1.0d0
12128       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12129         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12130         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12131       else
12132         sscale_ele=0d0
12133       endif
12134       return
12135       end function sscale_ele
12136
12137       real(kind=8)  function sscagrad_ele(r)
12138       real(kind=8) :: r,gamm
12139 !      include "COMMON.SPLITELE"
12140       if(r.lt.r_cut_ele-rlamb_ele) then
12141         sscagrad_ele=0.0d0
12142       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12143         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12144         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12145       else
12146         sscagrad_ele=0.0d0
12147       endif
12148       return
12149       end function sscagrad_ele
12150       real(kind=8) function sscalelip(r)
12151       real(kind=8) r,gamm
12152         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12153       return
12154       end function sscalelip
12155 !C-----------------------------------------------------------------------
12156       real(kind=8) function sscagradlip(r)
12157       real(kind=8) r,gamm
12158         sscagradlip=r*(6.0d0*r-6.0d0)
12159       return
12160       end function sscagradlip
12161
12162 !!!!!!!!!!!!!!!
12163 !-----------------------------------------------------------------------------
12164       subroutine elj_long(evdw)
12165 !
12166 ! This subroutine calculates the interaction energy of nonbonded side chains
12167 ! assuming the LJ potential of interaction.
12168 !
12169 !      implicit real*8 (a-h,o-z)
12170 !      include 'DIMENSIONS'
12171 !      include 'COMMON.GEO'
12172 !      include 'COMMON.VAR'
12173 !      include 'COMMON.LOCAL'
12174 !      include 'COMMON.CHAIN'
12175 !      include 'COMMON.DERIV'
12176 !      include 'COMMON.INTERACT'
12177 !      include 'COMMON.TORSION'
12178 !      include 'COMMON.SBRIDGE'
12179 !      include 'COMMON.NAMES'
12180 !      include 'COMMON.IOUNITS'
12181 !      include 'COMMON.CONTACTS'
12182       real(kind=8),parameter :: accur=1.0d-10
12183       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12184 !el local variables
12185       integer :: i,iint,j,k,itypi,itypi1,itypj
12186       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12187       real(kind=8) :: e1,e2,evdwij,evdw
12188 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12189       evdw=0.0D0
12190       do i=iatsc_s,iatsc_e
12191         itypi=itype(i)
12192         if (itypi.eq.ntyp1) cycle
12193         itypi1=itype(i+1)
12194         xi=c(1,nres+i)
12195         yi=c(2,nres+i)
12196         zi=c(3,nres+i)
12197 !
12198 ! Calculate SC interaction energy.
12199 !
12200         do iint=1,nint_gr(i)
12201 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12202 !d   &                  'iend=',iend(i,iint)
12203           do j=istart(i,iint),iend(i,iint)
12204             itypj=itype(j)
12205             if (itypj.eq.ntyp1) cycle
12206             xj=c(1,nres+j)-xi
12207             yj=c(2,nres+j)-yi
12208             zj=c(3,nres+j)-zi
12209             rij=xj*xj+yj*yj+zj*zj
12210             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12211             if (sss.lt.1.0d0) then
12212               rrij=1.0D0/rij
12213               eps0ij=eps(itypi,itypj)
12214               fac=rrij**expon2
12215               e1=fac*fac*aa_aq(itypi,itypj)
12216               e2=fac*bb_aq(itypi,itypj)
12217               evdwij=e1+e2
12218               evdw=evdw+(1.0d0-sss)*evdwij
12219 !
12220 ! Calculate the components of the gradient in DC and X
12221 !
12222               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12223               gg(1)=xj*fac
12224               gg(2)=yj*fac
12225               gg(3)=zj*fac
12226               do k=1,3
12227                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12228                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12229                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12230                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12231               enddo
12232             endif
12233           enddo      ! j
12234         enddo        ! iint
12235       enddo          ! i
12236       do i=1,nct
12237         do j=1,3
12238           gvdwc(j,i)=expon*gvdwc(j,i)
12239           gvdwx(j,i)=expon*gvdwx(j,i)
12240         enddo
12241       enddo
12242 !******************************************************************************
12243 !
12244 !                              N O T E !!!
12245 !
12246 ! To save time, the factor of EXPON has been extracted from ALL components
12247 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12248 ! use!
12249 !
12250 !******************************************************************************
12251       return
12252       end subroutine elj_long
12253 !-----------------------------------------------------------------------------
12254       subroutine elj_short(evdw)
12255 !
12256 ! This subroutine calculates the interaction energy of nonbonded side chains
12257 ! assuming the LJ potential of interaction.
12258 !
12259 !      implicit real*8 (a-h,o-z)
12260 !      include 'DIMENSIONS'
12261 !      include 'COMMON.GEO'
12262 !      include 'COMMON.VAR'
12263 !      include 'COMMON.LOCAL'
12264 !      include 'COMMON.CHAIN'
12265 !      include 'COMMON.DERIV'
12266 !      include 'COMMON.INTERACT'
12267 !      include 'COMMON.TORSION'
12268 !      include 'COMMON.SBRIDGE'
12269 !      include 'COMMON.NAMES'
12270 !      include 'COMMON.IOUNITS'
12271 !      include 'COMMON.CONTACTS'
12272       real(kind=8),parameter :: accur=1.0d-10
12273       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12274 !el local variables
12275       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12276       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12277       real(kind=8) :: e1,e2,evdwij,evdw
12278 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12279       evdw=0.0D0
12280       do i=iatsc_s,iatsc_e
12281         itypi=itype(i)
12282         if (itypi.eq.ntyp1) cycle
12283         itypi1=itype(i+1)
12284         xi=c(1,nres+i)
12285         yi=c(2,nres+i)
12286         zi=c(3,nres+i)
12287 ! Change 12/1/95
12288         num_conti=0
12289 !
12290 ! Calculate SC interaction energy.
12291 !
12292         do iint=1,nint_gr(i)
12293 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12294 !d   &                  'iend=',iend(i,iint)
12295           do j=istart(i,iint),iend(i,iint)
12296             itypj=itype(j)
12297             if (itypj.eq.ntyp1) cycle
12298             xj=c(1,nres+j)-xi
12299             yj=c(2,nres+j)-yi
12300             zj=c(3,nres+j)-zi
12301 ! Change 12/1/95 to calculate four-body interactions
12302             rij=xj*xj+yj*yj+zj*zj
12303             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12304             if (sss.gt.0.0d0) then
12305               rrij=1.0D0/rij
12306               eps0ij=eps(itypi,itypj)
12307               fac=rrij**expon2
12308               e1=fac*fac*aa_aq(itypi,itypj)
12309               e2=fac*bb_aq(itypi,itypj)
12310               evdwij=e1+e2
12311               evdw=evdw+sss*evdwij
12312 !
12313 ! Calculate the components of the gradient in DC and X
12314 !
12315               fac=-rrij*(e1+evdwij)*sss
12316               gg(1)=xj*fac
12317               gg(2)=yj*fac
12318               gg(3)=zj*fac
12319               do k=1,3
12320                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12321                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12322                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12323                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12324               enddo
12325             endif
12326           enddo      ! j
12327         enddo        ! iint
12328       enddo          ! i
12329       do i=1,nct
12330         do j=1,3
12331           gvdwc(j,i)=expon*gvdwc(j,i)
12332           gvdwx(j,i)=expon*gvdwx(j,i)
12333         enddo
12334       enddo
12335 !******************************************************************************
12336 !
12337 !                              N O T E !!!
12338 !
12339 ! To save time, the factor of EXPON has been extracted from ALL components
12340 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12341 ! use!
12342 !
12343 !******************************************************************************
12344       return
12345       end subroutine elj_short
12346 !-----------------------------------------------------------------------------
12347       subroutine eljk_long(evdw)
12348 !
12349 ! This subroutine calculates the interaction energy of nonbonded side chains
12350 ! assuming the LJK potential of interaction.
12351 !
12352 !      implicit real*8 (a-h,o-z)
12353 !      include 'DIMENSIONS'
12354 !      include 'COMMON.GEO'
12355 !      include 'COMMON.VAR'
12356 !      include 'COMMON.LOCAL'
12357 !      include 'COMMON.CHAIN'
12358 !      include 'COMMON.DERIV'
12359 !      include 'COMMON.INTERACT'
12360 !      include 'COMMON.IOUNITS'
12361 !      include 'COMMON.NAMES'
12362       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12363       logical :: scheck
12364 !el local variables
12365       integer :: i,iint,j,k,itypi,itypi1,itypj
12366       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12367                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12368 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12369       evdw=0.0D0
12370       do i=iatsc_s,iatsc_e
12371         itypi=itype(i)
12372         if (itypi.eq.ntyp1) cycle
12373         itypi1=itype(i+1)
12374         xi=c(1,nres+i)
12375         yi=c(2,nres+i)
12376         zi=c(3,nres+i)
12377 !
12378 ! Calculate SC interaction energy.
12379 !
12380         do iint=1,nint_gr(i)
12381           do j=istart(i,iint),iend(i,iint)
12382             itypj=itype(j)
12383             if (itypj.eq.ntyp1) cycle
12384             xj=c(1,nres+j)-xi
12385             yj=c(2,nres+j)-yi
12386             zj=c(3,nres+j)-zi
12387             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12388             fac_augm=rrij**expon
12389             e_augm=augm(itypi,itypj)*fac_augm
12390             r_inv_ij=dsqrt(rrij)
12391             rij=1.0D0/r_inv_ij
12392             sss=sscale(rij/sigma(itypi,itypj))
12393             if (sss.lt.1.0d0) then
12394               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12395               fac=r_shift_inv**expon
12396               e1=fac*fac*aa_aq(itypi,itypj)
12397               e2=fac*bb_aq(itypi,itypj)
12398               evdwij=e_augm+e1+e2
12399 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12400 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12401 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12402 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
12403 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12404 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12405 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12406               evdw=evdw+(1.0d0-sss)*evdwij
12407 !
12408 ! Calculate the components of the gradient in DC and X
12409 !
12410               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12411               fac=fac*(1.0d0-sss)
12412               gg(1)=xj*fac
12413               gg(2)=yj*fac
12414               gg(3)=zj*fac
12415               do k=1,3
12416                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12417                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12418                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12419                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12420               enddo
12421             endif
12422           enddo      ! j
12423         enddo        ! iint
12424       enddo          ! i
12425       do i=1,nct
12426         do j=1,3
12427           gvdwc(j,i)=expon*gvdwc(j,i)
12428           gvdwx(j,i)=expon*gvdwx(j,i)
12429         enddo
12430       enddo
12431       return
12432       end subroutine eljk_long
12433 !-----------------------------------------------------------------------------
12434       subroutine eljk_short(evdw)
12435 !
12436 ! This subroutine calculates the interaction energy of nonbonded side chains
12437 ! assuming the LJK potential of interaction.
12438 !
12439 !      implicit real*8 (a-h,o-z)
12440 !      include 'DIMENSIONS'
12441 !      include 'COMMON.GEO'
12442 !      include 'COMMON.VAR'
12443 !      include 'COMMON.LOCAL'
12444 !      include 'COMMON.CHAIN'
12445 !      include 'COMMON.DERIV'
12446 !      include 'COMMON.INTERACT'
12447 !      include 'COMMON.IOUNITS'
12448 !      include 'COMMON.NAMES'
12449       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12450       logical :: scheck
12451 !el local variables
12452       integer :: i,iint,j,k,itypi,itypi1,itypj
12453       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12454                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12455 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12456       evdw=0.0D0
12457       do i=iatsc_s,iatsc_e
12458         itypi=itype(i)
12459         if (itypi.eq.ntyp1) cycle
12460         itypi1=itype(i+1)
12461         xi=c(1,nres+i)
12462         yi=c(2,nres+i)
12463         zi=c(3,nres+i)
12464 !
12465 ! Calculate SC interaction energy.
12466 !
12467         do iint=1,nint_gr(i)
12468           do j=istart(i,iint),iend(i,iint)
12469             itypj=itype(j)
12470             if (itypj.eq.ntyp1) cycle
12471             xj=c(1,nres+j)-xi
12472             yj=c(2,nres+j)-yi
12473             zj=c(3,nres+j)-zi
12474             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12475             fac_augm=rrij**expon
12476             e_augm=augm(itypi,itypj)*fac_augm
12477             r_inv_ij=dsqrt(rrij)
12478             rij=1.0D0/r_inv_ij
12479             sss=sscale(rij/sigma(itypi,itypj))
12480             if (sss.gt.0.0d0) then
12481               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12482               fac=r_shift_inv**expon
12483               e1=fac*fac*aa_aq(itypi,itypj)
12484               e2=fac*bb_aq(itypi,itypj)
12485               evdwij=e_augm+e1+e2
12486 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12487 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12488 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12489 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
12490 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12491 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12492 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12493               evdw=evdw+sss*evdwij
12494 !
12495 ! Calculate the components of the gradient in DC and X
12496 !
12497               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12498               fac=fac*sss
12499               gg(1)=xj*fac
12500               gg(2)=yj*fac
12501               gg(3)=zj*fac
12502               do k=1,3
12503                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12504                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12505                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12506                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12507               enddo
12508             endif
12509           enddo      ! j
12510         enddo        ! iint
12511       enddo          ! i
12512       do i=1,nct
12513         do j=1,3
12514           gvdwc(j,i)=expon*gvdwc(j,i)
12515           gvdwx(j,i)=expon*gvdwx(j,i)
12516         enddo
12517       enddo
12518       return
12519       end subroutine eljk_short
12520 !-----------------------------------------------------------------------------
12521       subroutine ebp_long(evdw)
12522 !
12523 ! This subroutine calculates the interaction energy of nonbonded side chains
12524 ! assuming the Berne-Pechukas potential of interaction.
12525 !
12526       use calc_data
12527 !      implicit real*8 (a-h,o-z)
12528 !      include 'DIMENSIONS'
12529 !      include 'COMMON.GEO'
12530 !      include 'COMMON.VAR'
12531 !      include 'COMMON.LOCAL'
12532 !      include 'COMMON.CHAIN'
12533 !      include 'COMMON.DERIV'
12534 !      include 'COMMON.NAMES'
12535 !      include 'COMMON.INTERACT'
12536 !      include 'COMMON.IOUNITS'
12537 !      include 'COMMON.CALC'
12538       use comm_srutu
12539 !el      integer :: icall
12540 !el      common /srutu/ icall
12541 !     double precision rrsave(maxdim)
12542       logical :: lprn
12543 !el local variables
12544       integer :: iint,itypi,itypi1,itypj
12545       real(kind=8) :: rrij,xi,yi,zi,fac
12546       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12547       evdw=0.0D0
12548 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12549       evdw=0.0D0
12550 !     if (icall.eq.0) then
12551 !       lprn=.true.
12552 !     else
12553         lprn=.false.
12554 !     endif
12555 !el      ind=0
12556       do i=iatsc_s,iatsc_e
12557         itypi=itype(i)
12558         if (itypi.eq.ntyp1) cycle
12559         itypi1=itype(i+1)
12560         xi=c(1,nres+i)
12561         yi=c(2,nres+i)
12562         zi=c(3,nres+i)
12563         dxi=dc_norm(1,nres+i)
12564         dyi=dc_norm(2,nres+i)
12565         dzi=dc_norm(3,nres+i)
12566 !        dsci_inv=dsc_inv(itypi)
12567         dsci_inv=vbld_inv(i+nres)
12568 !
12569 ! Calculate SC interaction energy.
12570 !
12571         do iint=1,nint_gr(i)
12572           do j=istart(i,iint),iend(i,iint)
12573 !el            ind=ind+1
12574             itypj=itype(j)
12575             if (itypj.eq.ntyp1) cycle
12576 !            dscj_inv=dsc_inv(itypj)
12577             dscj_inv=vbld_inv(j+nres)
12578             chi1=chi(itypi,itypj)
12579             chi2=chi(itypj,itypi)
12580             chi12=chi1*chi2
12581             chip1=chip(itypi)
12582             chip2=chip(itypj)
12583             chip12=chip1*chip2
12584             alf1=alp(itypi)
12585             alf2=alp(itypj)
12586             alf12=0.5D0*(alf1+alf2)
12587             xj=c(1,nres+j)-xi
12588             yj=c(2,nres+j)-yi
12589             zj=c(3,nres+j)-zi
12590             dxj=dc_norm(1,nres+j)
12591             dyj=dc_norm(2,nres+j)
12592             dzj=dc_norm(3,nres+j)
12593             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12594             rij=dsqrt(rrij)
12595             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12596
12597             if (sss.lt.1.0d0) then
12598
12599 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12600               call sc_angular
12601 ! Calculate whole angle-dependent part of epsilon and contributions
12602 ! to its derivatives
12603               fac=(rrij*sigsq)**expon2
12604               e1=fac*fac*aa_aq(itypi,itypj)
12605               e2=fac*bb_aq(itypi,itypj)
12606               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12607               eps2der=evdwij*eps3rt
12608               eps3der=evdwij*eps2rt
12609               evdwij=evdwij*eps2rt*eps3rt
12610               evdw=evdw+evdwij*(1.0d0-sss)
12611               if (lprn) then
12612               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12613               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12614 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12615 !d     &          restyp(itypi),i,restyp(itypj),j,
12616 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12617 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12618 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12619 !d     &          evdwij
12620               endif
12621 ! Calculate gradient components.
12622               e1=e1*eps1*eps2rt**2*eps3rt**2
12623               fac=-expon*(e1+evdwij)
12624               sigder=fac/sigsq
12625               fac=rrij*fac
12626 ! Calculate radial part of the gradient
12627               gg(1)=xj*fac
12628               gg(2)=yj*fac
12629               gg(3)=zj*fac
12630 ! Calculate the angular part of the gradient and sum add the contributions
12631 ! to the appropriate components of the Cartesian gradient.
12632               call sc_grad_scale(1.0d0-sss)
12633             endif
12634           enddo      ! j
12635         enddo        ! iint
12636       enddo          ! i
12637 !     stop
12638       return
12639       end subroutine ebp_long
12640 !-----------------------------------------------------------------------------
12641       subroutine ebp_short(evdw)
12642 !
12643 ! This subroutine calculates the interaction energy of nonbonded side chains
12644 ! assuming the Berne-Pechukas potential of interaction.
12645 !
12646       use calc_data
12647 !      implicit real*8 (a-h,o-z)
12648 !      include 'DIMENSIONS'
12649 !      include 'COMMON.GEO'
12650 !      include 'COMMON.VAR'
12651 !      include 'COMMON.LOCAL'
12652 !      include 'COMMON.CHAIN'
12653 !      include 'COMMON.DERIV'
12654 !      include 'COMMON.NAMES'
12655 !      include 'COMMON.INTERACT'
12656 !      include 'COMMON.IOUNITS'
12657 !      include 'COMMON.CALC'
12658       use comm_srutu
12659 !el      integer :: icall
12660 !el      common /srutu/ icall
12661 !     double precision rrsave(maxdim)
12662       logical :: lprn
12663 !el local variables
12664       integer :: iint,itypi,itypi1,itypj
12665       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12666       real(kind=8) :: sss,e1,e2,evdw
12667       evdw=0.0D0
12668 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12669       evdw=0.0D0
12670 !     if (icall.eq.0) then
12671 !       lprn=.true.
12672 !     else
12673         lprn=.false.
12674 !     endif
12675 !el      ind=0
12676       do i=iatsc_s,iatsc_e
12677         itypi=itype(i)
12678         if (itypi.eq.ntyp1) cycle
12679         itypi1=itype(i+1)
12680         xi=c(1,nres+i)
12681         yi=c(2,nres+i)
12682         zi=c(3,nres+i)
12683         dxi=dc_norm(1,nres+i)
12684         dyi=dc_norm(2,nres+i)
12685         dzi=dc_norm(3,nres+i)
12686 !        dsci_inv=dsc_inv(itypi)
12687         dsci_inv=vbld_inv(i+nres)
12688 !
12689 ! Calculate SC interaction energy.
12690 !
12691         do iint=1,nint_gr(i)
12692           do j=istart(i,iint),iend(i,iint)
12693 !el            ind=ind+1
12694             itypj=itype(j)
12695             if (itypj.eq.ntyp1) cycle
12696 !            dscj_inv=dsc_inv(itypj)
12697             dscj_inv=vbld_inv(j+nres)
12698             chi1=chi(itypi,itypj)
12699             chi2=chi(itypj,itypi)
12700             chi12=chi1*chi2
12701             chip1=chip(itypi)
12702             chip2=chip(itypj)
12703             chip12=chip1*chip2
12704             alf1=alp(itypi)
12705             alf2=alp(itypj)
12706             alf12=0.5D0*(alf1+alf2)
12707             xj=c(1,nres+j)-xi
12708             yj=c(2,nres+j)-yi
12709             zj=c(3,nres+j)-zi
12710             dxj=dc_norm(1,nres+j)
12711             dyj=dc_norm(2,nres+j)
12712             dzj=dc_norm(3,nres+j)
12713             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12714             rij=dsqrt(rrij)
12715             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12716
12717             if (sss.gt.0.0d0) then
12718
12719 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12720               call sc_angular
12721 ! Calculate whole angle-dependent part of epsilon and contributions
12722 ! to its derivatives
12723               fac=(rrij*sigsq)**expon2
12724               e1=fac*fac*aa_aq(itypi,itypj)
12725               e2=fac*bb_aq(itypi,itypj)
12726               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12727               eps2der=evdwij*eps3rt
12728               eps3der=evdwij*eps2rt
12729               evdwij=evdwij*eps2rt*eps3rt
12730               evdw=evdw+evdwij*sss
12731               if (lprn) then
12732               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12733               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12734 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12735 !d     &          restyp(itypi),i,restyp(itypj),j,
12736 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12737 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12738 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12739 !d     &          evdwij
12740               endif
12741 ! Calculate gradient components.
12742               e1=e1*eps1*eps2rt**2*eps3rt**2
12743               fac=-expon*(e1+evdwij)
12744               sigder=fac/sigsq
12745               fac=rrij*fac
12746 ! Calculate radial part of the gradient
12747               gg(1)=xj*fac
12748               gg(2)=yj*fac
12749               gg(3)=zj*fac
12750 ! Calculate the angular part of the gradient and sum add the contributions
12751 ! to the appropriate components of the Cartesian gradient.
12752               call sc_grad_scale(sss)
12753             endif
12754           enddo      ! j
12755         enddo        ! iint
12756       enddo          ! i
12757 !     stop
12758       return
12759       end subroutine ebp_short
12760 !-----------------------------------------------------------------------------
12761       subroutine egb_long(evdw)
12762 !
12763 ! This subroutine calculates the interaction energy of nonbonded side chains
12764 ! assuming the Gay-Berne potential of interaction.
12765 !
12766       use calc_data
12767 !      implicit real*8 (a-h,o-z)
12768 !      include 'DIMENSIONS'
12769 !      include 'COMMON.GEO'
12770 !      include 'COMMON.VAR'
12771 !      include 'COMMON.LOCAL'
12772 !      include 'COMMON.CHAIN'
12773 !      include 'COMMON.DERIV'
12774 !      include 'COMMON.NAMES'
12775 !      include 'COMMON.INTERACT'
12776 !      include 'COMMON.IOUNITS'
12777 !      include 'COMMON.CALC'
12778 !      include 'COMMON.CONTROL'
12779       logical :: lprn
12780 !el local variables
12781       integer :: iint,itypi,itypi1,itypj,subchap
12782       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
12783       real(kind=8) :: sss,e1,e2,evdw,sss_grad
12784       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
12785                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
12786                     ssgradlipi,ssgradlipj
12787
12788
12789       evdw=0.0D0
12790 !cccc      energy_dec=.false.
12791 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12792       evdw=0.0D0
12793       lprn=.false.
12794 !     if (icall.eq.0) lprn=.false.
12795 !el      ind=0
12796       do i=iatsc_s,iatsc_e
12797         itypi=itype(i)
12798         if (itypi.eq.ntyp1) cycle
12799         itypi1=itype(i+1)
12800         xi=c(1,nres+i)
12801         yi=c(2,nres+i)
12802         zi=c(3,nres+i)
12803           xi=mod(xi,boxxsize)
12804           if (xi.lt.0) xi=xi+boxxsize
12805           yi=mod(yi,boxysize)
12806           if (yi.lt.0) yi=yi+boxysize
12807           zi=mod(zi,boxzsize)
12808           if (zi.lt.0) zi=zi+boxzsize
12809        if ((zi.gt.bordlipbot)    &
12810         .and.(zi.lt.bordliptop)) then
12811 !C the energy transfer exist
12812         if (zi.lt.buflipbot) then
12813 !C what fraction I am in
12814          fracinbuf=1.0d0-    &
12815              ((zi-bordlipbot)/lipbufthick)
12816 !C lipbufthick is thickenes of lipid buffore
12817          sslipi=sscalelip(fracinbuf)
12818          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
12819         elseif (zi.gt.bufliptop) then
12820          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
12821          sslipi=sscalelip(fracinbuf)
12822          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
12823         else
12824          sslipi=1.0d0
12825          ssgradlipi=0.0
12826         endif
12827        else
12828          sslipi=0.0d0
12829          ssgradlipi=0.0
12830        endif
12831
12832         dxi=dc_norm(1,nres+i)
12833         dyi=dc_norm(2,nres+i)
12834         dzi=dc_norm(3,nres+i)
12835 !        dsci_inv=dsc_inv(itypi)
12836         dsci_inv=vbld_inv(i+nres)
12837 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
12838 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
12839 !
12840 ! Calculate SC interaction energy.
12841 !
12842         do iint=1,nint_gr(i)
12843           do j=istart(i,iint),iend(i,iint)
12844             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
12845 !              call dyn_ssbond_ene(i,j,evdwij)
12846 !              evdw=evdw+evdwij
12847 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12848 !                              'evdw',i,j,evdwij,' ss'
12849 !              if (energy_dec) write (iout,*) &
12850 !                              'evdw',i,j,evdwij,' ss'
12851 !             do k=j+1,iend(i,iint)
12852 !C search over all next residues
12853 !              if (dyn_ss_mask(k)) then
12854 !C check if they are cysteins
12855 !C              write(iout,*) 'k=',k
12856
12857 !c              write(iout,*) "PRZED TRI", evdwij
12858 !               evdwij_przed_tri=evdwij
12859 !              call triple_ssbond_ene(i,j,k,evdwij)
12860 !c               if(evdwij_przed_tri.ne.evdwij) then
12861 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
12862 !c               endif
12863
12864 !c              write(iout,*) "PO TRI", evdwij
12865 !C call the energy function that removes the artifical triple disulfide
12866 !C bond the soubroutine is located in ssMD.F
12867 !              evdw=evdw+evdwij
12868               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12869                             'evdw',i,j,evdwij,'tss'
12870 !              endif!dyn_ss_mask(k)
12871 !             enddo! k
12872
12873             ELSE
12874 !el            ind=ind+1
12875             itypj=itype(j)
12876             if (itypj.eq.ntyp1) cycle
12877 !            dscj_inv=dsc_inv(itypj)
12878             dscj_inv=vbld_inv(j+nres)
12879 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
12880 !     &       1.0d0/vbld(j+nres)
12881 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
12882             sig0ij=sigma(itypi,itypj)
12883             chi1=chi(itypi,itypj)
12884             chi2=chi(itypj,itypi)
12885             chi12=chi1*chi2
12886             chip1=chip(itypi)
12887             chip2=chip(itypj)
12888             chip12=chip1*chip2
12889             alf1=alp(itypi)
12890             alf2=alp(itypj)
12891             alf12=0.5D0*(alf1+alf2)
12892             xj=c(1,nres+j)
12893             yj=c(2,nres+j)
12894             zj=c(3,nres+j)
12895 ! Searching for nearest neighbour
12896           xj=mod(xj,boxxsize)
12897           if (xj.lt.0) xj=xj+boxxsize
12898           yj=mod(yj,boxysize)
12899           if (yj.lt.0) yj=yj+boxysize
12900           zj=mod(zj,boxzsize)
12901           if (zj.lt.0) zj=zj+boxzsize
12902        if ((zj.gt.bordlipbot)   &
12903       .and.(zj.lt.bordliptop)) then
12904 !C the energy transfer exist
12905         if (zj.lt.buflipbot) then
12906 !C what fraction I am in
12907          fracinbuf=1.0d0-  &
12908              ((zj-bordlipbot)/lipbufthick)
12909 !C lipbufthick is thickenes of lipid buffore
12910          sslipj=sscalelip(fracinbuf)
12911          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
12912         elseif (zj.gt.bufliptop) then
12913          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
12914          sslipj=sscalelip(fracinbuf)
12915          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
12916         else
12917          sslipj=1.0d0
12918          ssgradlipj=0.0
12919         endif
12920        else
12921          sslipj=0.0d0
12922          ssgradlipj=0.0
12923        endif
12924       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12925        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12926       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12927        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12928
12929           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12930           xj_safe=xj
12931           yj_safe=yj
12932           zj_safe=zj
12933           subchap=0
12934           do xshift=-1,1
12935           do yshift=-1,1
12936           do zshift=-1,1
12937           xj=xj_safe+xshift*boxxsize
12938           yj=yj_safe+yshift*boxysize
12939           zj=zj_safe+zshift*boxzsize
12940           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12941           if(dist_temp.lt.dist_init) then
12942             dist_init=dist_temp
12943             xj_temp=xj
12944             yj_temp=yj
12945             zj_temp=zj
12946             subchap=1
12947           endif
12948           enddo
12949           enddo
12950           enddo
12951           if (subchap.eq.1) then
12952           xj=xj_temp-xi
12953           yj=yj_temp-yi
12954           zj=zj_temp-zi
12955           else
12956           xj=xj_safe-xi
12957           yj=yj_safe-yi
12958           zj=zj_safe-zi
12959           endif
12960
12961             dxj=dc_norm(1,nres+j)
12962             dyj=dc_norm(2,nres+j)
12963             dzj=dc_norm(3,nres+j)
12964             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12965             rij=dsqrt(rrij)
12966             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12967             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
12968             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
12969             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
12970             if (sss_ele_cut.le.0.0) cycle
12971             if (sss.lt.1.0d0) then
12972
12973 ! Calculate angle-dependent terms of energy and contributions to their
12974 ! derivatives.
12975               call sc_angular
12976               sigsq=1.0D0/sigsq
12977               sig=sig0ij*dsqrt(sigsq)
12978               rij_shift=1.0D0/rij-sig+sig0ij
12979 ! for diagnostics; uncomment
12980 !              rij_shift=1.2*sig0ij
12981 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12982               if (rij_shift.le.0.0D0) then
12983                 evdw=1.0D20
12984 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
12985 !d     &          restyp(itypi),i,restyp(itypj),j,
12986 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
12987                 return
12988               endif
12989               sigder=-sig*sigsq
12990 !---------------------------------------------------------------
12991               rij_shift=1.0D0/rij_shift
12992               fac=rij_shift**expon
12993               e1=fac*fac*aa
12994               e2=fac*bb
12995               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12996               eps2der=evdwij*eps3rt
12997               eps3der=evdwij*eps2rt
12998 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
12999 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13000               evdwij=evdwij*eps2rt*eps3rt
13001               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13002               if (lprn) then
13003               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13004               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13005               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13006                 restyp(itypi),i,restyp(itypj),j,&
13007                 epsi,sigm,chi1,chi2,chip1,chip2,&
13008                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13009                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13010                 evdwij
13011               endif
13012
13013               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13014                               'evdw',i,j,evdwij
13015 !              if (energy_dec) write (iout,*) &
13016 !                              'evdw',i,j,evdwij,"egb_long"
13017
13018 ! Calculate gradient components.
13019               e1=e1*eps1*eps2rt**2*eps3rt**2
13020               fac=-expon*(e1+evdwij)*rij_shift
13021               sigder=fac*sigder
13022               fac=rij*fac
13023               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13024             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13025             /sigmaii(itypi,itypj))
13026 !              fac=0.0d0
13027 ! Calculate the radial part of the gradient
13028               gg(1)=xj*fac
13029               gg(2)=yj*fac
13030               gg(3)=zj*fac
13031 ! Calculate angular part of the gradient.
13032               call sc_grad_scale(1.0d0-sss)
13033             ENDIF    !mask_dyn_ss
13034             endif
13035           enddo      ! j
13036         enddo        ! iint
13037       enddo          ! i
13038 !      write (iout,*) "Number of loop steps in EGB:",ind
13039 !ccc      energy_dec=.false.
13040       return
13041       end subroutine egb_long
13042 !-----------------------------------------------------------------------------
13043       subroutine egb_short(evdw)
13044 !
13045 ! This subroutine calculates the interaction energy of nonbonded side chains
13046 ! assuming the Gay-Berne potential of interaction.
13047 !
13048       use calc_data
13049 !      implicit real*8 (a-h,o-z)
13050 !      include 'DIMENSIONS'
13051 !      include 'COMMON.GEO'
13052 !      include 'COMMON.VAR'
13053 !      include 'COMMON.LOCAL'
13054 !      include 'COMMON.CHAIN'
13055 !      include 'COMMON.DERIV'
13056 !      include 'COMMON.NAMES'
13057 !      include 'COMMON.INTERACT'
13058 !      include 'COMMON.IOUNITS'
13059 !      include 'COMMON.CALC'
13060 !      include 'COMMON.CONTROL'
13061       logical :: lprn
13062 !el local variables
13063       integer :: iint,itypi,itypi1,itypj,subchap
13064       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13065       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13066       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13067                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13068                     ssgradlipi,ssgradlipj
13069       evdw=0.0D0
13070 !cccc      energy_dec=.false.
13071 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13072       evdw=0.0D0
13073       lprn=.false.
13074 !     if (icall.eq.0) lprn=.false.
13075 !el      ind=0
13076       do i=iatsc_s,iatsc_e
13077         itypi=itype(i)
13078         if (itypi.eq.ntyp1) cycle
13079         itypi1=itype(i+1)
13080         xi=c(1,nres+i)
13081         yi=c(2,nres+i)
13082         zi=c(3,nres+i)
13083           xi=mod(xi,boxxsize)
13084           if (xi.lt.0) xi=xi+boxxsize
13085           yi=mod(yi,boxysize)
13086           if (yi.lt.0) yi=yi+boxysize
13087           zi=mod(zi,boxzsize)
13088           if (zi.lt.0) zi=zi+boxzsize
13089        if ((zi.gt.bordlipbot)    &
13090         .and.(zi.lt.bordliptop)) then
13091 !C the energy transfer exist
13092         if (zi.lt.buflipbot) then
13093 !C what fraction I am in
13094          fracinbuf=1.0d0-    &
13095              ((zi-bordlipbot)/lipbufthick)
13096 !C lipbufthick is thickenes of lipid buffore
13097          sslipi=sscalelip(fracinbuf)
13098          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13099         elseif (zi.gt.bufliptop) then
13100          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13101          sslipi=sscalelip(fracinbuf)
13102          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13103         else
13104          sslipi=1.0d0
13105          ssgradlipi=0.0
13106         endif
13107        else
13108          sslipi=0.0d0
13109          ssgradlipi=0.0
13110        endif
13111
13112         dxi=dc_norm(1,nres+i)
13113         dyi=dc_norm(2,nres+i)
13114         dzi=dc_norm(3,nres+i)
13115 !        dsci_inv=dsc_inv(itypi)
13116         dsci_inv=vbld_inv(i+nres)
13117
13118         dxi=dc_norm(1,nres+i)
13119         dyi=dc_norm(2,nres+i)
13120         dzi=dc_norm(3,nres+i)
13121 !        dsci_inv=dsc_inv(itypi)
13122         dsci_inv=vbld_inv(i+nres)
13123 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13124 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13125 !
13126 ! Calculate SC interaction energy.
13127 !
13128         do iint=1,nint_gr(i)
13129           do j=istart(i,iint),iend(i,iint)
13130             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13131               call dyn_ssbond_ene(i,j,evdwij)
13132               evdw=evdw+evdwij
13133               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13134                               'evdw',i,j,evdwij,' ss'
13135              do k=j+1,iend(i,iint)
13136 !C search over all next residues
13137               if (dyn_ss_mask(k)) then
13138 !C check if they are cysteins
13139 !C              write(iout,*) 'k=',k
13140
13141 !c              write(iout,*) "PRZED TRI", evdwij
13142 !               evdwij_przed_tri=evdwij
13143               call triple_ssbond_ene(i,j,k,evdwij)
13144 !c               if(evdwij_przed_tri.ne.evdwij) then
13145 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13146 !c               endif
13147
13148 !c              write(iout,*) "PO TRI", evdwij
13149 !C call the energy function that removes the artifical triple disulfide
13150 !C bond the soubroutine is located in ssMD.F
13151               evdw=evdw+evdwij
13152               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13153                             'evdw',i,j,evdwij,'tss'
13154               endif!dyn_ss_mask(k)
13155              enddo! k
13156
13157 !              if (energy_dec) write (iout,*) &
13158 !                              'evdw',i,j,evdwij,' ss'
13159             ELSE
13160 !el            ind=ind+1
13161             itypj=itype(j)
13162             if (itypj.eq.ntyp1) cycle
13163 !            dscj_inv=dsc_inv(itypj)
13164             dscj_inv=vbld_inv(j+nres)
13165 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13166 !     &       1.0d0/vbld(j+nres)
13167 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
13168             sig0ij=sigma(itypi,itypj)
13169             chi1=chi(itypi,itypj)
13170             chi2=chi(itypj,itypi)
13171             chi12=chi1*chi2
13172             chip1=chip(itypi)
13173             chip2=chip(itypj)
13174             chip12=chip1*chip2
13175             alf1=alp(itypi)
13176             alf2=alp(itypj)
13177             alf12=0.5D0*(alf1+alf2)
13178 !            xj=c(1,nres+j)-xi
13179 !            yj=c(2,nres+j)-yi
13180 !            zj=c(3,nres+j)-zi
13181             xj=c(1,nres+j)
13182             yj=c(2,nres+j)
13183             zj=c(3,nres+j)
13184 ! Searching for nearest neighbour
13185           xj=mod(xj,boxxsize)
13186           if (xj.lt.0) xj=xj+boxxsize
13187           yj=mod(yj,boxysize)
13188           if (yj.lt.0) yj=yj+boxysize
13189           zj=mod(zj,boxzsize)
13190           if (zj.lt.0) zj=zj+boxzsize
13191        if ((zj.gt.bordlipbot)   &
13192       .and.(zj.lt.bordliptop)) then
13193 !C the energy transfer exist
13194         if (zj.lt.buflipbot) then
13195 !C what fraction I am in
13196          fracinbuf=1.0d0-  &
13197              ((zj-bordlipbot)/lipbufthick)
13198 !C lipbufthick is thickenes of lipid buffore
13199          sslipj=sscalelip(fracinbuf)
13200          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13201         elseif (zj.gt.bufliptop) then
13202          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13203          sslipj=sscalelip(fracinbuf)
13204          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13205         else
13206          sslipj=1.0d0
13207          ssgradlipj=0.0
13208         endif
13209        else
13210          sslipj=0.0d0
13211          ssgradlipj=0.0
13212        endif
13213       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13214        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13215       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13216        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13217
13218           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13219           xj_safe=xj
13220           yj_safe=yj
13221           zj_safe=zj
13222           subchap=0
13223
13224           do xshift=-1,1
13225           do yshift=-1,1
13226           do zshift=-1,1
13227           xj=xj_safe+xshift*boxxsize
13228           yj=yj_safe+yshift*boxysize
13229           zj=zj_safe+zshift*boxzsize
13230           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13231           if(dist_temp.lt.dist_init) then
13232             dist_init=dist_temp
13233             xj_temp=xj
13234             yj_temp=yj
13235             zj_temp=zj
13236             subchap=1
13237           endif
13238           enddo
13239           enddo
13240           enddo
13241           if (subchap.eq.1) then
13242           xj=xj_temp-xi
13243           yj=yj_temp-yi
13244           zj=zj_temp-zi
13245           else
13246           xj=xj_safe-xi
13247           yj=yj_safe-yi
13248           zj=zj_safe-zi
13249           endif
13250
13251             dxj=dc_norm(1,nres+j)
13252             dyj=dc_norm(2,nres+j)
13253             dzj=dc_norm(3,nres+j)
13254             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13255             rij=dsqrt(rrij)
13256             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13257             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13258             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13259             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13260             if (sss_ele_cut.le.0.0) cycle
13261
13262             if (sss.gt.0.0d0) then
13263
13264 ! Calculate angle-dependent terms of energy and contributions to their
13265 ! derivatives.
13266               call sc_angular
13267               sigsq=1.0D0/sigsq
13268               sig=sig0ij*dsqrt(sigsq)
13269               rij_shift=1.0D0/rij-sig+sig0ij
13270 ! for diagnostics; uncomment
13271 !              rij_shift=1.2*sig0ij
13272 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13273               if (rij_shift.le.0.0D0) then
13274                 evdw=1.0D20
13275 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13276 !d     &          restyp(itypi),i,restyp(itypj),j,
13277 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13278                 return
13279               endif
13280               sigder=-sig*sigsq
13281 !---------------------------------------------------------------
13282               rij_shift=1.0D0/rij_shift
13283               fac=rij_shift**expon
13284               e1=fac*fac*aa
13285               e2=fac*bb
13286               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13287               eps2der=evdwij*eps3rt
13288               eps3der=evdwij*eps2rt
13289 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13290 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13291               evdwij=evdwij*eps2rt*eps3rt
13292               evdw=evdw+evdwij*sss*sss_ele_cut
13293               if (lprn) then
13294               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13295               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13296               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13297                 restyp(itypi),i,restyp(itypj),j,&
13298                 epsi,sigm,chi1,chi2,chip1,chip2,&
13299                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13300                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13301                 evdwij
13302               endif
13303
13304               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13305                               'evdw',i,j,evdwij
13306 !              if (energy_dec) write (iout,*) &
13307 !                              'evdw',i,j,evdwij,"egb_short"
13308
13309 ! Calculate gradient components.
13310               e1=e1*eps1*eps2rt**2*eps3rt**2
13311               fac=-expon*(e1+evdwij)*rij_shift
13312               sigder=fac*sigder
13313               fac=rij*fac
13314               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13315             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13316             /sigmaii(itypi,itypj))
13317
13318 !              fac=0.0d0
13319 ! Calculate the radial part of the gradient
13320               gg(1)=xj*fac
13321               gg(2)=yj*fac
13322               gg(3)=zj*fac
13323 ! Calculate angular part of the gradient.
13324               call sc_grad_scale(sss)
13325             endif
13326           ENDIF !mask_dyn_ss
13327           enddo      ! j
13328         enddo        ! iint
13329       enddo          ! i
13330 !      write (iout,*) "Number of loop steps in EGB:",ind
13331 !ccc      energy_dec=.false.
13332       return
13333       end subroutine egb_short
13334 !-----------------------------------------------------------------------------
13335       subroutine egbv_long(evdw)
13336 !
13337 ! This subroutine calculates the interaction energy of nonbonded side chains
13338 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13339 !
13340       use calc_data
13341 !      implicit real*8 (a-h,o-z)
13342 !      include 'DIMENSIONS'
13343 !      include 'COMMON.GEO'
13344 !      include 'COMMON.VAR'
13345 !      include 'COMMON.LOCAL'
13346 !      include 'COMMON.CHAIN'
13347 !      include 'COMMON.DERIV'
13348 !      include 'COMMON.NAMES'
13349 !      include 'COMMON.INTERACT'
13350 !      include 'COMMON.IOUNITS'
13351 !      include 'COMMON.CALC'
13352       use comm_srutu
13353 !el      integer :: icall
13354 !el      common /srutu/ icall
13355       logical :: lprn
13356 !el local variables
13357       integer :: iint,itypi,itypi1,itypj
13358       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13359       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13360       evdw=0.0D0
13361 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13362       evdw=0.0D0
13363       lprn=.false.
13364 !     if (icall.eq.0) lprn=.true.
13365 !el      ind=0
13366       do i=iatsc_s,iatsc_e
13367         itypi=itype(i)
13368         if (itypi.eq.ntyp1) cycle
13369         itypi1=itype(i+1)
13370         xi=c(1,nres+i)
13371         yi=c(2,nres+i)
13372         zi=c(3,nres+i)
13373         dxi=dc_norm(1,nres+i)
13374         dyi=dc_norm(2,nres+i)
13375         dzi=dc_norm(3,nres+i)
13376 !        dsci_inv=dsc_inv(itypi)
13377         dsci_inv=vbld_inv(i+nres)
13378 !
13379 ! Calculate SC interaction energy.
13380 !
13381         do iint=1,nint_gr(i)
13382           do j=istart(i,iint),iend(i,iint)
13383 !el            ind=ind+1
13384             itypj=itype(j)
13385             if (itypj.eq.ntyp1) cycle
13386 !            dscj_inv=dsc_inv(itypj)
13387             dscj_inv=vbld_inv(j+nres)
13388             sig0ij=sigma(itypi,itypj)
13389             r0ij=r0(itypi,itypj)
13390             chi1=chi(itypi,itypj)
13391             chi2=chi(itypj,itypi)
13392             chi12=chi1*chi2
13393             chip1=chip(itypi)
13394             chip2=chip(itypj)
13395             chip12=chip1*chip2
13396             alf1=alp(itypi)
13397             alf2=alp(itypj)
13398             alf12=0.5D0*(alf1+alf2)
13399             xj=c(1,nres+j)-xi
13400             yj=c(2,nres+j)-yi
13401             zj=c(3,nres+j)-zi
13402             dxj=dc_norm(1,nres+j)
13403             dyj=dc_norm(2,nres+j)
13404             dzj=dc_norm(3,nres+j)
13405             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13406             rij=dsqrt(rrij)
13407
13408             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13409
13410             if (sss.lt.1.0d0) then
13411
13412 ! Calculate angle-dependent terms of energy and contributions to their
13413 ! derivatives.
13414               call sc_angular
13415               sigsq=1.0D0/sigsq
13416               sig=sig0ij*dsqrt(sigsq)
13417               rij_shift=1.0D0/rij-sig+r0ij
13418 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13419               if (rij_shift.le.0.0D0) then
13420                 evdw=1.0D20
13421                 return
13422               endif
13423               sigder=-sig*sigsq
13424 !---------------------------------------------------------------
13425               rij_shift=1.0D0/rij_shift
13426               fac=rij_shift**expon
13427               e1=fac*fac*aa_aq(itypi,itypj)
13428               e2=fac*bb_aq(itypi,itypj)
13429               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13430               eps2der=evdwij*eps3rt
13431               eps3der=evdwij*eps2rt
13432               fac_augm=rrij**expon
13433               e_augm=augm(itypi,itypj)*fac_augm
13434               evdwij=evdwij*eps2rt*eps3rt
13435               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13436               if (lprn) then
13437               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13438               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13439               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13440                 restyp(itypi),i,restyp(itypj),j,&
13441                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13442                 chi1,chi2,chip1,chip2,&
13443                 eps1,eps2rt**2,eps3rt**2,&
13444                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13445                 evdwij+e_augm
13446               endif
13447 ! Calculate gradient components.
13448               e1=e1*eps1*eps2rt**2*eps3rt**2
13449               fac=-expon*(e1+evdwij)*rij_shift
13450               sigder=fac*sigder
13451               fac=rij*fac-2*expon*rrij*e_augm
13452 ! Calculate the radial part of the gradient
13453               gg(1)=xj*fac
13454               gg(2)=yj*fac
13455               gg(3)=zj*fac
13456 ! Calculate angular part of the gradient.
13457               call sc_grad_scale(1.0d0-sss)
13458             endif
13459           enddo      ! j
13460         enddo        ! iint
13461       enddo          ! i
13462       end subroutine egbv_long
13463 !-----------------------------------------------------------------------------
13464       subroutine egbv_short(evdw)
13465 !
13466 ! This subroutine calculates the interaction energy of nonbonded side chains
13467 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13468 !
13469       use calc_data
13470 !      implicit real*8 (a-h,o-z)
13471 !      include 'DIMENSIONS'
13472 !      include 'COMMON.GEO'
13473 !      include 'COMMON.VAR'
13474 !      include 'COMMON.LOCAL'
13475 !      include 'COMMON.CHAIN'
13476 !      include 'COMMON.DERIV'
13477 !      include 'COMMON.NAMES'
13478 !      include 'COMMON.INTERACT'
13479 !      include 'COMMON.IOUNITS'
13480 !      include 'COMMON.CALC'
13481       use comm_srutu
13482 !el      integer :: icall
13483 !el      common /srutu/ icall
13484       logical :: lprn
13485 !el local variables
13486       integer :: iint,itypi,itypi1,itypj
13487       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13488       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13489       evdw=0.0D0
13490 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13491       evdw=0.0D0
13492       lprn=.false.
13493 !     if (icall.eq.0) lprn=.true.
13494 !el      ind=0
13495       do i=iatsc_s,iatsc_e
13496         itypi=itype(i)
13497         if (itypi.eq.ntyp1) cycle
13498         itypi1=itype(i+1)
13499         xi=c(1,nres+i)
13500         yi=c(2,nres+i)
13501         zi=c(3,nres+i)
13502         dxi=dc_norm(1,nres+i)
13503         dyi=dc_norm(2,nres+i)
13504         dzi=dc_norm(3,nres+i)
13505 !        dsci_inv=dsc_inv(itypi)
13506         dsci_inv=vbld_inv(i+nres)
13507 !
13508 ! Calculate SC interaction energy.
13509 !
13510         do iint=1,nint_gr(i)
13511           do j=istart(i,iint),iend(i,iint)
13512 !el            ind=ind+1
13513             itypj=itype(j)
13514             if (itypj.eq.ntyp1) cycle
13515 !            dscj_inv=dsc_inv(itypj)
13516             dscj_inv=vbld_inv(j+nres)
13517             sig0ij=sigma(itypi,itypj)
13518             r0ij=r0(itypi,itypj)
13519             chi1=chi(itypi,itypj)
13520             chi2=chi(itypj,itypi)
13521             chi12=chi1*chi2
13522             chip1=chip(itypi)
13523             chip2=chip(itypj)
13524             chip12=chip1*chip2
13525             alf1=alp(itypi)
13526             alf2=alp(itypj)
13527             alf12=0.5D0*(alf1+alf2)
13528             xj=c(1,nres+j)-xi
13529             yj=c(2,nres+j)-yi
13530             zj=c(3,nres+j)-zi
13531             dxj=dc_norm(1,nres+j)
13532             dyj=dc_norm(2,nres+j)
13533             dzj=dc_norm(3,nres+j)
13534             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13535             rij=dsqrt(rrij)
13536
13537             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13538
13539             if (sss.gt.0.0d0) then
13540
13541 ! Calculate angle-dependent terms of energy and contributions to their
13542 ! derivatives.
13543               call sc_angular
13544               sigsq=1.0D0/sigsq
13545               sig=sig0ij*dsqrt(sigsq)
13546               rij_shift=1.0D0/rij-sig+r0ij
13547 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13548               if (rij_shift.le.0.0D0) then
13549                 evdw=1.0D20
13550                 return
13551               endif
13552               sigder=-sig*sigsq
13553 !---------------------------------------------------------------
13554               rij_shift=1.0D0/rij_shift
13555               fac=rij_shift**expon
13556               e1=fac*fac*aa_aq(itypi,itypj)
13557               e2=fac*bb_aq(itypi,itypj)
13558               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13559               eps2der=evdwij*eps3rt
13560               eps3der=evdwij*eps2rt
13561               fac_augm=rrij**expon
13562               e_augm=augm(itypi,itypj)*fac_augm
13563               evdwij=evdwij*eps2rt*eps3rt
13564               evdw=evdw+(evdwij+e_augm)*sss
13565               if (lprn) then
13566               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13567               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13568               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13569                 restyp(itypi),i,restyp(itypj),j,&
13570                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13571                 chi1,chi2,chip1,chip2,&
13572                 eps1,eps2rt**2,eps3rt**2,&
13573                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13574                 evdwij+e_augm
13575               endif
13576 ! Calculate gradient components.
13577               e1=e1*eps1*eps2rt**2*eps3rt**2
13578               fac=-expon*(e1+evdwij)*rij_shift
13579               sigder=fac*sigder
13580               fac=rij*fac-2*expon*rrij*e_augm
13581 ! Calculate the radial part of the gradient
13582               gg(1)=xj*fac
13583               gg(2)=yj*fac
13584               gg(3)=zj*fac
13585 ! Calculate angular part of the gradient.
13586               call sc_grad_scale(sss)
13587             endif
13588           enddo      ! j
13589         enddo        ! iint
13590       enddo          ! i
13591       end subroutine egbv_short
13592 !-----------------------------------------------------------------------------
13593       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13594 !
13595 ! This subroutine calculates the average interaction energy and its gradient
13596 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13597 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13598 ! The potential depends both on the distance of peptide-group centers and on
13599 ! the orientation of the CA-CA virtual bonds.
13600 !
13601 !      implicit real*8 (a-h,o-z)
13602
13603       use comm_locel
13604 #ifdef MPI
13605       include 'mpif.h'
13606 #endif
13607 !      include 'DIMENSIONS'
13608 !      include 'COMMON.CONTROL'
13609 !      include 'COMMON.SETUP'
13610 !      include 'COMMON.IOUNITS'
13611 !      include 'COMMON.GEO'
13612 !      include 'COMMON.VAR'
13613 !      include 'COMMON.LOCAL'
13614 !      include 'COMMON.CHAIN'
13615 !      include 'COMMON.DERIV'
13616 !      include 'COMMON.INTERACT'
13617 !      include 'COMMON.CONTACTS'
13618 !      include 'COMMON.TORSION'
13619 !      include 'COMMON.VECTORS'
13620 !      include 'COMMON.FFIELD'
13621 !      include 'COMMON.TIME1'
13622       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13623       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13624       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13625 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13626       real(kind=8),dimension(4) :: muij
13627 !el      integer :: num_conti,j1,j2
13628 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13629 !el                   dz_normi,xmedi,ymedi,zmedi
13630 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13631 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13632 !el          num_conti,j1,j2
13633 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13634 #ifdef MOMENT
13635       real(kind=8) :: scal_el=1.0d0
13636 #else
13637       real(kind=8) :: scal_el=0.5d0
13638 #endif
13639 ! 12/13/98
13640 ! 13-go grudnia roku pamietnego...
13641       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13642                                              0.0d0,1.0d0,0.0d0,&
13643                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13644 !el local variables
13645       integer :: i,j,k
13646       real(kind=8) :: fac
13647       real(kind=8) :: dxj,dyj,dzj
13648       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13649
13650 !      allocate(num_cont_hb(nres)) !(maxres)
13651 !d      write(iout,*) 'In EELEC'
13652 !d      do i=1,nloctyp
13653 !d        write(iout,*) 'Type',i
13654 !d        write(iout,*) 'B1',B1(:,i)
13655 !d        write(iout,*) 'B2',B2(:,i)
13656 !d        write(iout,*) 'CC',CC(:,:,i)
13657 !d        write(iout,*) 'DD',DD(:,:,i)
13658 !d        write(iout,*) 'EE',EE(:,:,i)
13659 !d      enddo
13660 !d      call check_vecgrad
13661 !d      stop
13662       if (icheckgrad.eq.1) then
13663         do i=1,nres-1
13664           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13665           do k=1,3
13666             dc_norm(k,i)=dc(k,i)*fac
13667           enddo
13668 !          write (iout,*) 'i',i,' fac',fac
13669         enddo
13670       endif
13671       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13672           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13673           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13674 !        call vec_and_deriv
13675 #ifdef TIMING
13676         time01=MPI_Wtime()
13677 #endif
13678 !        print *, "before set matrices"
13679         call set_matrices
13680 !        print *,"after set martices"
13681 #ifdef TIMING
13682         time_mat=time_mat+MPI_Wtime()-time01
13683 #endif
13684       endif
13685 !d      do i=1,nres-1
13686 !d        write (iout,*) 'i=',i
13687 !d        do k=1,3
13688 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
13689 !d        enddo
13690 !d        do k=1,3
13691 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
13692 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
13693 !d        enddo
13694 !d      enddo
13695       t_eelecij=0.0d0
13696       ees=0.0D0
13697       evdw1=0.0D0
13698       eel_loc=0.0d0
13699       eello_turn3=0.0d0
13700       eello_turn4=0.0d0
13701 !el      ind=0
13702       do i=1,nres
13703         num_cont_hb(i)=0
13704       enddo
13705 !d      print '(a)','Enter EELEC'
13706 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
13707 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13708 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13709       do i=1,nres
13710         gel_loc_loc(i)=0.0d0
13711         gcorr_loc(i)=0.0d0
13712       enddo
13713 !
13714 !
13715 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
13716 !
13717 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
13718 !
13719       do i=iturn3_start,iturn3_end
13720         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
13721         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
13722         dxi=dc(1,i)
13723         dyi=dc(2,i)
13724         dzi=dc(3,i)
13725         dx_normi=dc_norm(1,i)
13726         dy_normi=dc_norm(2,i)
13727         dz_normi=dc_norm(3,i)
13728         xmedi=c(1,i)+0.5d0*dxi
13729         ymedi=c(2,i)+0.5d0*dyi
13730         zmedi=c(3,i)+0.5d0*dzi
13731           xmedi=dmod(xmedi,boxxsize)
13732           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13733           ymedi=dmod(ymedi,boxysize)
13734           if (ymedi.lt.0) ymedi=ymedi+boxysize
13735           zmedi=dmod(zmedi,boxzsize)
13736           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13737         num_conti=0
13738         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
13739         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
13740         num_cont_hb(i)=num_conti
13741       enddo
13742       do i=iturn4_start,iturn4_end
13743         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
13744           .or. itype(i+3).eq.ntyp1 &
13745           .or. itype(i+4).eq.ntyp1) cycle
13746         dxi=dc(1,i)
13747         dyi=dc(2,i)
13748         dzi=dc(3,i)
13749         dx_normi=dc_norm(1,i)
13750         dy_normi=dc_norm(2,i)
13751         dz_normi=dc_norm(3,i)
13752         xmedi=c(1,i)+0.5d0*dxi
13753         ymedi=c(2,i)+0.5d0*dyi
13754         zmedi=c(3,i)+0.5d0*dzi
13755           xmedi=dmod(xmedi,boxxsize)
13756           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13757           ymedi=dmod(ymedi,boxysize)
13758           if (ymedi.lt.0) ymedi=ymedi+boxysize
13759           zmedi=dmod(zmedi,boxzsize)
13760           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13761         num_conti=num_cont_hb(i)
13762         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
13763         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
13764           call eturn4(i,eello_turn4)
13765         num_cont_hb(i)=num_conti
13766       enddo   ! i
13767 !
13768 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
13769 !
13770       do i=iatel_s,iatel_e
13771         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13772         dxi=dc(1,i)
13773         dyi=dc(2,i)
13774         dzi=dc(3,i)
13775         dx_normi=dc_norm(1,i)
13776         dy_normi=dc_norm(2,i)
13777         dz_normi=dc_norm(3,i)
13778         xmedi=c(1,i)+0.5d0*dxi
13779         ymedi=c(2,i)+0.5d0*dyi
13780         zmedi=c(3,i)+0.5d0*dzi
13781           xmedi=dmod(xmedi,boxxsize)
13782           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13783           ymedi=dmod(ymedi,boxysize)
13784           if (ymedi.lt.0) ymedi=ymedi+boxysize
13785           zmedi=dmod(zmedi,boxzsize)
13786           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13787 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
13788         num_conti=num_cont_hb(i)
13789         do j=ielstart(i),ielend(i)
13790           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
13791           call eelecij_scale(i,j,ees,evdw1,eel_loc)
13792         enddo ! j
13793         num_cont_hb(i)=num_conti
13794       enddo   ! i
13795 !      write (iout,*) "Number of loop steps in EELEC:",ind
13796 !d      do i=1,nres
13797 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
13798 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
13799 !d      enddo
13800 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
13801 !cc      eel_loc=eel_loc+eello_turn3
13802 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
13803       return
13804       end subroutine eelec_scale
13805 !-----------------------------------------------------------------------------
13806       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
13807 !      implicit real*8 (a-h,o-z)
13808
13809       use comm_locel
13810 !      include 'DIMENSIONS'
13811 #ifdef MPI
13812       include "mpif.h"
13813 #endif
13814 !      include 'COMMON.CONTROL'
13815 !      include 'COMMON.IOUNITS'
13816 !      include 'COMMON.GEO'
13817 !      include 'COMMON.VAR'
13818 !      include 'COMMON.LOCAL'
13819 !      include 'COMMON.CHAIN'
13820 !      include 'COMMON.DERIV'
13821 !      include 'COMMON.INTERACT'
13822 !      include 'COMMON.CONTACTS'
13823 !      include 'COMMON.TORSION'
13824 !      include 'COMMON.VECTORS'
13825 !      include 'COMMON.FFIELD'
13826 !      include 'COMMON.TIME1'
13827       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
13828       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
13829       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13830 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13831       real(kind=8),dimension(4) :: muij
13832       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13833                     dist_temp, dist_init,sss_grad
13834       integer xshift,yshift,zshift
13835
13836 !el      integer :: num_conti,j1,j2
13837 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13838 !el                   dz_normi,xmedi,ymedi,zmedi
13839 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13840 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13841 !el          num_conti,j1,j2
13842 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13843 #ifdef MOMENT
13844       real(kind=8) :: scal_el=1.0d0
13845 #else
13846       real(kind=8) :: scal_el=0.5d0
13847 #endif
13848 ! 12/13/98
13849 ! 13-go grudnia roku pamietnego...
13850       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13851                                              0.0d0,1.0d0,0.0d0,&
13852                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13853 !el local variables
13854       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
13855       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
13856       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
13857       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
13858       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
13859       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
13860       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
13861                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
13862                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
13863                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
13864                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
13865                   ecosam,ecosbm,ecosgm,ghalf,time00
13866 !      integer :: maxconts
13867 !      maxconts = nres/4
13868 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13869 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13870 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13871 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13872 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13873 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13874 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13875 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13876 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
13877 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
13878 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
13879 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
13880 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
13881
13882 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
13883 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
13884
13885 #ifdef MPI
13886           time00=MPI_Wtime()
13887 #endif
13888 !d      write (iout,*) "eelecij",i,j
13889 !el          ind=ind+1
13890           iteli=itel(i)
13891           itelj=itel(j)
13892           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
13893           aaa=app(iteli,itelj)
13894           bbb=bpp(iteli,itelj)
13895           ael6i=ael6(iteli,itelj)
13896           ael3i=ael3(iteli,itelj)
13897           dxj=dc(1,j)
13898           dyj=dc(2,j)
13899           dzj=dc(3,j)
13900           dx_normj=dc_norm(1,j)
13901           dy_normj=dc_norm(2,j)
13902           dz_normj=dc_norm(3,j)
13903 !          xj=c(1,j)+0.5D0*dxj-xmedi
13904 !          yj=c(2,j)+0.5D0*dyj-ymedi
13905 !          zj=c(3,j)+0.5D0*dzj-zmedi
13906           xj=c(1,j)+0.5D0*dxj
13907           yj=c(2,j)+0.5D0*dyj
13908           zj=c(3,j)+0.5D0*dzj
13909           xj=mod(xj,boxxsize)
13910           if (xj.lt.0) xj=xj+boxxsize
13911           yj=mod(yj,boxysize)
13912           if (yj.lt.0) yj=yj+boxysize
13913           zj=mod(zj,boxzsize)
13914           if (zj.lt.0) zj=zj+boxzsize
13915       isubchap=0
13916       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13917       xj_safe=xj
13918       yj_safe=yj
13919       zj_safe=zj
13920       do xshift=-1,1
13921       do yshift=-1,1
13922       do zshift=-1,1
13923           xj=xj_safe+xshift*boxxsize
13924           yj=yj_safe+yshift*boxysize
13925           zj=zj_safe+zshift*boxzsize
13926           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13927           if(dist_temp.lt.dist_init) then
13928             dist_init=dist_temp
13929             xj_temp=xj
13930             yj_temp=yj
13931             zj_temp=zj
13932             isubchap=1
13933           endif
13934        enddo
13935        enddo
13936        enddo
13937        if (isubchap.eq.1) then
13938 !C          print *,i,j
13939           xj=xj_temp-xmedi
13940           yj=yj_temp-ymedi
13941           zj=zj_temp-zmedi
13942        else
13943           xj=xj_safe-xmedi
13944           yj=yj_safe-ymedi
13945           zj=zj_safe-zmedi
13946        endif
13947
13948           rij=xj*xj+yj*yj+zj*zj
13949           rrmij=1.0D0/rij
13950           rij=dsqrt(rij)
13951           rmij=1.0D0/rij
13952 ! For extracting the short-range part of Evdwpp
13953           sss=sscale(rij/rpp(iteli,itelj))
13954             sss_ele_cut=sscale_ele(rij)
13955             sss_ele_grad=sscagrad_ele(rij)
13956             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
13957 !             sss_ele_cut=1.0d0
13958 !             sss_ele_grad=0.0d0
13959             if (sss_ele_cut.le.0.0) go to 128
13960
13961           r3ij=rrmij*rmij
13962           r6ij=r3ij*r3ij
13963           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
13964           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
13965           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
13966           fac=cosa-3.0D0*cosb*cosg
13967           ev1=aaa*r6ij*r6ij
13968 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
13969           if (j.eq.i+2) ev1=scal_el*ev1
13970           ev2=bbb*r6ij
13971           fac3=ael6i*r6ij
13972           fac4=ael3i*r3ij
13973           evdwij=ev1+ev2
13974           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
13975           el2=fac4*fac
13976           eesij=el1+el2
13977 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
13978           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
13979           ees=ees+eesij*sss_ele_cut
13980           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
13981 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
13982 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
13983 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
13984 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
13985
13986           if (energy_dec) then
13987               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
13988               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
13989           endif
13990
13991 !
13992 ! Calculate contributions to the Cartesian gradient.
13993 !
13994 #ifdef SPLITELE
13995           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
13996           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
13997           fac1=fac
13998           erij(1)=xj*rmij
13999           erij(2)=yj*rmij
14000           erij(3)=zj*rmij
14001 !
14002 ! Radial derivatives. First process both termini of the fragment (i,j)
14003 !
14004           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14005           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14006           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14007 !          do k=1,3
14008 !            ghalf=0.5D0*ggg(k)
14009 !            gelc(k,i)=gelc(k,i)+ghalf
14010 !            gelc(k,j)=gelc(k,j)+ghalf
14011 !          enddo
14012 ! 9/28/08 AL Gradient compotents will be summed only at the end
14013           do k=1,3
14014             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14015             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14016           enddo
14017 !
14018 ! Loop over residues i+1 thru j-1.
14019 !
14020 !grad          do k=i+1,j-1
14021 !grad            do l=1,3
14022 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14023 !grad            enddo
14024 !grad          enddo
14025           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14026           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14027           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14028           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14029           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14030           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14031 !          do k=1,3
14032 !            ghalf=0.5D0*ggg(k)
14033 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14034 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14035 !          enddo
14036 ! 9/28/08 AL Gradient compotents will be summed only at the end
14037           do k=1,3
14038             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14039             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14040           enddo
14041 !
14042 ! Loop over residues i+1 thru j-1.
14043 !
14044 !grad          do k=i+1,j-1
14045 !grad            do l=1,3
14046 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14047 !grad            enddo
14048 !grad          enddo
14049 #else
14050           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14051           facel=(el1+eesij)*sss_ele_cut
14052           fac1=fac
14053           fac=-3*rrmij*(facvdw+facvdw+facel)
14054           erij(1)=xj*rmij
14055           erij(2)=yj*rmij
14056           erij(3)=zj*rmij
14057 !
14058 ! Radial derivatives. First process both termini of the fragment (i,j)
14059 !
14060           ggg(1)=fac*xj
14061           ggg(2)=fac*yj
14062           ggg(3)=fac*zj
14063 !          do k=1,3
14064 !            ghalf=0.5D0*ggg(k)
14065 !            gelc(k,i)=gelc(k,i)+ghalf
14066 !            gelc(k,j)=gelc(k,j)+ghalf
14067 !          enddo
14068 ! 9/28/08 AL Gradient compotents will be summed only at the end
14069           do k=1,3
14070             gelc_long(k,j)=gelc(k,j)+ggg(k)
14071             gelc_long(k,i)=gelc(k,i)-ggg(k)
14072           enddo
14073 !
14074 ! Loop over residues i+1 thru j-1.
14075 !
14076 !grad          do k=i+1,j-1
14077 !grad            do l=1,3
14078 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14079 !grad            enddo
14080 !grad          enddo
14081 ! 9/28/08 AL Gradient compotents will be summed only at the end
14082           ggg(1)=facvdw*xj
14083           ggg(2)=facvdw*yj
14084           ggg(3)=facvdw*zj
14085           do k=1,3
14086             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14087             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14088           enddo
14089 #endif
14090 !
14091 ! Angular part
14092 !
14093           ecosa=2.0D0*fac3*fac1+fac4
14094           fac4=-3.0D0*fac4
14095           fac3=-6.0D0*fac3
14096           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14097           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14098           do k=1,3
14099             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14100             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14101           enddo
14102 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14103 !d   &          (dcosg(k),k=1,3)
14104           do k=1,3
14105             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14106           enddo
14107 !          do k=1,3
14108 !            ghalf=0.5D0*ggg(k)
14109 !            gelc(k,i)=gelc(k,i)+ghalf
14110 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14111 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14112 !            gelc(k,j)=gelc(k,j)+ghalf
14113 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14114 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14115 !          enddo
14116 !grad          do k=i+1,j-1
14117 !grad            do l=1,3
14118 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14119 !grad            enddo
14120 !grad          enddo
14121           do k=1,3
14122             gelc(k,i)=gelc(k,i) &
14123                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14124                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14125                      *sss_ele_cut
14126             gelc(k,j)=gelc(k,j) &
14127                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14128                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14129                      *sss_ele_cut
14130             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14131             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14132           enddo
14133           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14134               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14135               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14136 !
14137 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14138 !   energy of a peptide unit is assumed in the form of a second-order
14139 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14140 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14141 !   are computed for EVERY pair of non-contiguous peptide groups.
14142 !
14143           if (j.lt.nres-1) then
14144             j1=j+1
14145             j2=j-1
14146           else
14147             j1=j-1
14148             j2=j-2
14149           endif
14150           kkk=0
14151           do k=1,2
14152             do l=1,2
14153               kkk=kkk+1
14154               muij(kkk)=mu(k,i)*mu(l,j)
14155             enddo
14156           enddo
14157 !d         write (iout,*) 'EELEC: i',i,' j',j
14158 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14159 !d          write(iout,*) 'muij',muij
14160           ury=scalar(uy(1,i),erij)
14161           urz=scalar(uz(1,i),erij)
14162           vry=scalar(uy(1,j),erij)
14163           vrz=scalar(uz(1,j),erij)
14164           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14165           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14166           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14167           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14168           fac=dsqrt(-ael6i)*r3ij
14169           a22=a22*fac
14170           a23=a23*fac
14171           a32=a32*fac
14172           a33=a33*fac
14173 !d          write (iout,'(4i5,4f10.5)')
14174 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
14175 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14176 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14177 !d     &      uy(:,j),uz(:,j)
14178 !d          write (iout,'(4f10.5)')
14179 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14180 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14181 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14182 !d           write (iout,'(9f10.5/)')
14183 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14184 ! Derivatives of the elements of A in virtual-bond vectors
14185           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14186           do k=1,3
14187             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14188             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14189             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14190             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14191             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14192             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14193             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14194             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14195             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14196             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14197             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14198             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14199           enddo
14200 ! Compute radial contributions to the gradient
14201           facr=-3.0d0*rrmij
14202           a22der=a22*facr
14203           a23der=a23*facr
14204           a32der=a32*facr
14205           a33der=a33*facr
14206           agg(1,1)=a22der*xj
14207           agg(2,1)=a22der*yj
14208           agg(3,1)=a22der*zj
14209           agg(1,2)=a23der*xj
14210           agg(2,2)=a23der*yj
14211           agg(3,2)=a23der*zj
14212           agg(1,3)=a32der*xj
14213           agg(2,3)=a32der*yj
14214           agg(3,3)=a32der*zj
14215           agg(1,4)=a33der*xj
14216           agg(2,4)=a33der*yj
14217           agg(3,4)=a33der*zj
14218 ! Add the contributions coming from er
14219           fac3=-3.0d0*fac
14220           do k=1,3
14221             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14222             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14223             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14224             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14225           enddo
14226           do k=1,3
14227 ! Derivatives in DC(i)
14228 !grad            ghalf1=0.5d0*agg(k,1)
14229 !grad            ghalf2=0.5d0*agg(k,2)
14230 !grad            ghalf3=0.5d0*agg(k,3)
14231 !grad            ghalf4=0.5d0*agg(k,4)
14232             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14233             -3.0d0*uryg(k,2)*vry)!+ghalf1
14234             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14235             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14236             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14237             -3.0d0*urzg(k,2)*vry)!+ghalf3
14238             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14239             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14240 ! Derivatives in DC(i+1)
14241             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14242             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14243             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14244             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14245             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14246             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14247             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14248             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14249 ! Derivatives in DC(j)
14250             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14251             -3.0d0*vryg(k,2)*ury)!+ghalf1
14252             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14253             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14254             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14255             -3.0d0*vryg(k,2)*urz)!+ghalf3
14256             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14257             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14258 ! Derivatives in DC(j+1) or DC(nres-1)
14259             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14260             -3.0d0*vryg(k,3)*ury)
14261             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14262             -3.0d0*vrzg(k,3)*ury)
14263             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14264             -3.0d0*vryg(k,3)*urz)
14265             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14266             -3.0d0*vrzg(k,3)*urz)
14267 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14268 !grad              do l=1,4
14269 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14270 !grad              enddo
14271 !grad            endif
14272           enddo
14273           acipa(1,1)=a22
14274           acipa(1,2)=a23
14275           acipa(2,1)=a32
14276           acipa(2,2)=a33
14277           a22=-a22
14278           a23=-a23
14279           do l=1,2
14280             do k=1,3
14281               agg(k,l)=-agg(k,l)
14282               aggi(k,l)=-aggi(k,l)
14283               aggi1(k,l)=-aggi1(k,l)
14284               aggj(k,l)=-aggj(k,l)
14285               aggj1(k,l)=-aggj1(k,l)
14286             enddo
14287           enddo
14288           if (j.lt.nres-1) then
14289             a22=-a22
14290             a32=-a32
14291             do l=1,3,2
14292               do k=1,3
14293                 agg(k,l)=-agg(k,l)
14294                 aggi(k,l)=-aggi(k,l)
14295                 aggi1(k,l)=-aggi1(k,l)
14296                 aggj(k,l)=-aggj(k,l)
14297                 aggj1(k,l)=-aggj1(k,l)
14298               enddo
14299             enddo
14300           else
14301             a22=-a22
14302             a23=-a23
14303             a32=-a32
14304             a33=-a33
14305             do l=1,4
14306               do k=1,3
14307                 agg(k,l)=-agg(k,l)
14308                 aggi(k,l)=-aggi(k,l)
14309                 aggi1(k,l)=-aggi1(k,l)
14310                 aggj(k,l)=-aggj(k,l)
14311                 aggj1(k,l)=-aggj1(k,l)
14312               enddo
14313             enddo
14314           endif
14315           ENDIF ! WCORR
14316           IF (wel_loc.gt.0.0d0) THEN
14317 ! Contribution to the local-electrostatic energy coming from the i-j pair
14318           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14319            +a33*muij(4)
14320 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14321
14322           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14323                   'eelloc',i,j,eel_loc_ij
14324 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14325
14326           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14327 ! Partial derivatives in virtual-bond dihedral angles gamma
14328           if (i.gt.1) &
14329           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14330                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14331                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14332                  *sss_ele_cut
14333           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14334                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14335                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14336                  *sss_ele_cut
14337            xtemp(1)=xj
14338            xtemp(2)=yj
14339            xtemp(3)=zj
14340
14341 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14342           do l=1,3
14343             ggg(l)=(agg(l,1)*muij(1)+ &
14344                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14345             *sss_ele_cut &
14346              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14347
14348             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14349             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14350 !grad            ghalf=0.5d0*ggg(l)
14351 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14352 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14353           enddo
14354 !grad          do k=i+1,j2
14355 !grad            do l=1,3
14356 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14357 !grad            enddo
14358 !grad          enddo
14359 ! Remaining derivatives of eello
14360           do l=1,3
14361             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14362                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14363             *sss_ele_cut
14364
14365             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14366                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14367             *sss_ele_cut
14368
14369             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14370                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14371             *sss_ele_cut
14372
14373             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14374                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14375             *sss_ele_cut
14376
14377           enddo
14378           ENDIF
14379 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14380 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14381           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14382              .and. num_conti.le.maxconts) then
14383 !            write (iout,*) i,j," entered corr"
14384 !
14385 ! Calculate the contact function. The ith column of the array JCONT will
14386 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14387 ! greater than I). The arrays FACONT and GACONT will contain the values of
14388 ! the contact function and its derivative.
14389 !           r0ij=1.02D0*rpp(iteli,itelj)
14390 !           r0ij=1.11D0*rpp(iteli,itelj)
14391             r0ij=2.20D0*rpp(iteli,itelj)
14392 !           r0ij=1.55D0*rpp(iteli,itelj)
14393             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14394 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14395             if (fcont.gt.0.0D0) then
14396               num_conti=num_conti+1
14397               if (num_conti.gt.maxconts) then
14398 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14399                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14400                                ' will skip next contacts for this conf.',num_conti
14401               else
14402                 jcont_hb(num_conti,i)=j
14403 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14404 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14405                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14406                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14407 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14408 !  terms.
14409                 d_cont(num_conti,i)=rij
14410 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14411 !     --- Electrostatic-interaction matrix ---
14412                 a_chuj(1,1,num_conti,i)=a22
14413                 a_chuj(1,2,num_conti,i)=a23
14414                 a_chuj(2,1,num_conti,i)=a32
14415                 a_chuj(2,2,num_conti,i)=a33
14416 !     --- Gradient of rij
14417                 do kkk=1,3
14418                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14419                 enddo
14420                 kkll=0
14421                 do k=1,2
14422                   do l=1,2
14423                     kkll=kkll+1
14424                     do m=1,3
14425                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14426                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14427                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14428                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14429                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14430                     enddo
14431                   enddo
14432                 enddo
14433                 ENDIF
14434                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14435 ! Calculate contact energies
14436                 cosa4=4.0D0*cosa
14437                 wij=cosa-3.0D0*cosb*cosg
14438                 cosbg1=cosb+cosg
14439                 cosbg2=cosb-cosg
14440 !               fac3=dsqrt(-ael6i)/r0ij**3
14441                 fac3=dsqrt(-ael6i)*r3ij
14442 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14443                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14444                 if (ees0tmp.gt.0) then
14445                   ees0pij=dsqrt(ees0tmp)
14446                 else
14447                   ees0pij=0
14448                 endif
14449 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14450                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14451                 if (ees0tmp.gt.0) then
14452                   ees0mij=dsqrt(ees0tmp)
14453                 else
14454                   ees0mij=0
14455                 endif
14456 !               ees0mij=0.0D0
14457                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14458                      *sss_ele_cut
14459
14460                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14461                      *sss_ele_cut
14462
14463 ! Diagnostics. Comment out or remove after debugging!
14464 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14465 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14466 !               ees0m(num_conti,i)=0.0D0
14467 ! End diagnostics.
14468 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14469 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14470 ! Angular derivatives of the contact function
14471                 ees0pij1=fac3/ees0pij
14472                 ees0mij1=fac3/ees0mij
14473                 fac3p=-3.0D0*fac3*rrmij
14474                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14475                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14476 !               ees0mij1=0.0D0
14477                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14478                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14479                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14480                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14481                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14482                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14483                 ecosap=ecosa1+ecosa2
14484                 ecosbp=ecosb1+ecosb2
14485                 ecosgp=ecosg1+ecosg2
14486                 ecosam=ecosa1-ecosa2
14487                 ecosbm=ecosb1-ecosb2
14488                 ecosgm=ecosg1-ecosg2
14489 ! Diagnostics
14490 !               ecosap=ecosa1
14491 !               ecosbp=ecosb1
14492 !               ecosgp=ecosg1
14493 !               ecosam=0.0D0
14494 !               ecosbm=0.0D0
14495 !               ecosgm=0.0D0
14496 ! End diagnostics
14497                 facont_hb(num_conti,i)=fcont
14498                 fprimcont=fprimcont/rij
14499 !d              facont_hb(num_conti,i)=1.0D0
14500 ! Following line is for diagnostics.
14501 !d              fprimcont=0.0D0
14502                 do k=1,3
14503                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14504                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14505                 enddo
14506                 do k=1,3
14507                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14508                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14509                 enddo
14510 !                gggp(1)=gggp(1)+ees0pijp*xj
14511 !                gggp(2)=gggp(2)+ees0pijp*yj
14512 !                gggp(3)=gggp(3)+ees0pijp*zj
14513 !                gggm(1)=gggm(1)+ees0mijp*xj
14514 !                gggm(2)=gggm(2)+ees0mijp*yj
14515 !                gggm(3)=gggm(3)+ees0mijp*zj
14516                 gggp(1)=gggp(1)+ees0pijp*xj &
14517                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14518                 gggp(2)=gggp(2)+ees0pijp*yj &
14519                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14520                 gggp(3)=gggp(3)+ees0pijp*zj &
14521                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14522
14523                 gggm(1)=gggm(1)+ees0mijp*xj &
14524                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14525
14526                 gggm(2)=gggm(2)+ees0mijp*yj &
14527                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14528
14529                 gggm(3)=gggm(3)+ees0mijp*zj &
14530                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14531
14532 ! Derivatives due to the contact function
14533                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14534                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14535                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14536                 do k=1,3
14537 !
14538 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14539 !          following the change of gradient-summation algorithm.
14540 !
14541 !grad                  ghalfp=0.5D0*gggp(k)
14542 !grad                  ghalfm=0.5D0*gggm(k)
14543 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14544 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14545 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14546 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14547 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14548 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14549 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14550 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14551 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14552 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14553 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14554 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14555 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14556 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14557                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14558                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14559                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14560                      *sss_ele_cut
14561
14562                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14563                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14564                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14565                      *sss_ele_cut
14566
14567                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14568                      *sss_ele_cut
14569
14570                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14571                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14572                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14573                      *sss_ele_cut
14574
14575                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14576                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14577                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14578                      *sss_ele_cut
14579
14580                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14581                      *sss_ele_cut
14582
14583                 enddo
14584               ENDIF ! wcorr
14585               endif  ! num_conti.le.maxconts
14586             endif  ! fcont.gt.0
14587           endif    ! j.gt.i+1
14588           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14589             do k=1,4
14590               do l=1,3
14591                 ghalf=0.5d0*agg(l,k)
14592                 aggi(l,k)=aggi(l,k)+ghalf
14593                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14594                 aggj(l,k)=aggj(l,k)+ghalf
14595               enddo
14596             enddo
14597             if (j.eq.nres-1 .and. i.lt.j-2) then
14598               do k=1,4
14599                 do l=1,3
14600                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14601                 enddo
14602               enddo
14603             endif
14604           endif
14605  128      continue
14606 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14607       return
14608       end subroutine eelecij_scale
14609 !-----------------------------------------------------------------------------
14610       subroutine evdwpp_short(evdw1)
14611 !
14612 ! Compute Evdwpp
14613 !
14614 !      implicit real*8 (a-h,o-z)
14615 !      include 'DIMENSIONS'
14616 !      include 'COMMON.CONTROL'
14617 !      include 'COMMON.IOUNITS'
14618 !      include 'COMMON.GEO'
14619 !      include 'COMMON.VAR'
14620 !      include 'COMMON.LOCAL'
14621 !      include 'COMMON.CHAIN'
14622 !      include 'COMMON.DERIV'
14623 !      include 'COMMON.INTERACT'
14624 !      include 'COMMON.CONTACTS'
14625 !      include 'COMMON.TORSION'
14626 !      include 'COMMON.VECTORS'
14627 !      include 'COMMON.FFIELD'
14628       real(kind=8),dimension(3) :: ggg
14629 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14630 #ifdef MOMENT
14631       real(kind=8) :: scal_el=1.0d0
14632 #else
14633       real(kind=8) :: scal_el=0.5d0
14634 #endif
14635 !el local variables
14636       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14637       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14638       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14639                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14640                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14641       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14642                     dist_temp, dist_init,sss_grad
14643       integer xshift,yshift,zshift
14644
14645
14646       evdw1=0.0D0
14647 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14648 !     & " iatel_e_vdw",iatel_e_vdw
14649       call flush(iout)
14650       do i=iatel_s_vdw,iatel_e_vdw
14651         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
14652         dxi=dc(1,i)
14653         dyi=dc(2,i)
14654         dzi=dc(3,i)
14655         dx_normi=dc_norm(1,i)
14656         dy_normi=dc_norm(2,i)
14657         dz_normi=dc_norm(3,i)
14658         xmedi=c(1,i)+0.5d0*dxi
14659         ymedi=c(2,i)+0.5d0*dyi
14660         zmedi=c(3,i)+0.5d0*dzi
14661           xmedi=dmod(xmedi,boxxsize)
14662           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14663           ymedi=dmod(ymedi,boxysize)
14664           if (ymedi.lt.0) ymedi=ymedi+boxysize
14665           zmedi=dmod(zmedi,boxzsize)
14666           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14667         num_conti=0
14668 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14669 !     &   ' ielend',ielend_vdw(i)
14670         call flush(iout)
14671         do j=ielstart_vdw(i),ielend_vdw(i)
14672           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
14673 !el          ind=ind+1
14674           iteli=itel(i)
14675           itelj=itel(j)
14676           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14677           aaa=app(iteli,itelj)
14678           bbb=bpp(iteli,itelj)
14679           dxj=dc(1,j)
14680           dyj=dc(2,j)
14681           dzj=dc(3,j)
14682           dx_normj=dc_norm(1,j)
14683           dy_normj=dc_norm(2,j)
14684           dz_normj=dc_norm(3,j)
14685 !          xj=c(1,j)+0.5D0*dxj-xmedi
14686 !          yj=c(2,j)+0.5D0*dyj-ymedi
14687 !          zj=c(3,j)+0.5D0*dzj-zmedi
14688           xj=c(1,j)+0.5D0*dxj
14689           yj=c(2,j)+0.5D0*dyj
14690           zj=c(3,j)+0.5D0*dzj
14691           xj=mod(xj,boxxsize)
14692           if (xj.lt.0) xj=xj+boxxsize
14693           yj=mod(yj,boxysize)
14694           if (yj.lt.0) yj=yj+boxysize
14695           zj=mod(zj,boxzsize)
14696           if (zj.lt.0) zj=zj+boxzsize
14697       isubchap=0
14698       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14699       xj_safe=xj
14700       yj_safe=yj
14701       zj_safe=zj
14702       do xshift=-1,1
14703       do yshift=-1,1
14704       do zshift=-1,1
14705           xj=xj_safe+xshift*boxxsize
14706           yj=yj_safe+yshift*boxysize
14707           zj=zj_safe+zshift*boxzsize
14708           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14709           if(dist_temp.lt.dist_init) then
14710             dist_init=dist_temp
14711             xj_temp=xj
14712             yj_temp=yj
14713             zj_temp=zj
14714             isubchap=1
14715           endif
14716        enddo
14717        enddo
14718        enddo
14719        if (isubchap.eq.1) then
14720 !C          print *,i,j
14721           xj=xj_temp-xmedi
14722           yj=yj_temp-ymedi
14723           zj=zj_temp-zmedi
14724        else
14725           xj=xj_safe-xmedi
14726           yj=yj_safe-ymedi
14727           zj=zj_safe-zmedi
14728        endif
14729
14730           rij=xj*xj+yj*yj+zj*zj
14731           rrmij=1.0D0/rij
14732           rij=dsqrt(rij)
14733           sss=sscale(rij/rpp(iteli,itelj))
14734             sss_ele_cut=sscale_ele(rij)
14735             sss_ele_grad=sscagrad_ele(rij)
14736             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14737             if (sss_ele_cut.le.0.0) cycle
14738           if (sss.gt.0.0d0) then
14739             rmij=1.0D0/rij
14740             r3ij=rrmij*rmij
14741             r6ij=r3ij*r3ij
14742             ev1=aaa*r6ij*r6ij
14743 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14744             if (j.eq.i+2) ev1=scal_el*ev1
14745             ev2=bbb*r6ij
14746             evdwij=ev1+ev2
14747             if (energy_dec) then
14748               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14749             endif
14750             evdw1=evdw1+evdwij*sss*sss_ele_cut
14751 !
14752 ! Calculate contributions to the Cartesian gradient.
14753 !
14754             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
14755 !            ggg(1)=facvdw*xj
14756 !            ggg(2)=facvdw*yj
14757 !            ggg(3)=facvdw*zj
14758           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
14759           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14760           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
14761           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14762           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
14763           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14764
14765             do k=1,3
14766               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14767               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14768             enddo
14769           endif
14770         enddo ! j
14771       enddo   ! i
14772       return
14773       end subroutine evdwpp_short
14774 !-----------------------------------------------------------------------------
14775       subroutine escp_long(evdw2,evdw2_14)
14776 !
14777 ! This subroutine calculates the excluded-volume interaction energy between
14778 ! peptide-group centers and side chains and its gradient in virtual-bond and
14779 ! side-chain vectors.
14780 !
14781 !      implicit real*8 (a-h,o-z)
14782 !      include 'DIMENSIONS'
14783 !      include 'COMMON.GEO'
14784 !      include 'COMMON.VAR'
14785 !      include 'COMMON.LOCAL'
14786 !      include 'COMMON.CHAIN'
14787 !      include 'COMMON.DERIV'
14788 !      include 'COMMON.INTERACT'
14789 !      include 'COMMON.FFIELD'
14790 !      include 'COMMON.IOUNITS'
14791 !      include 'COMMON.CONTROL'
14792       real(kind=8),dimension(3) :: ggg
14793 !el local variables
14794       integer :: i,iint,j,k,iteli,itypj,subchap
14795       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
14796       real(kind=8) :: evdw2,evdw2_14,evdwij
14797       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14798                     dist_temp, dist_init
14799
14800       evdw2=0.0D0
14801       evdw2_14=0.0d0
14802 !d    print '(a)','Enter ESCP'
14803 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
14804       do i=iatscp_s,iatscp_e
14805         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
14806         iteli=itel(i)
14807         xi=0.5D0*(c(1,i)+c(1,i+1))
14808         yi=0.5D0*(c(2,i)+c(2,i+1))
14809         zi=0.5D0*(c(3,i)+c(3,i+1))
14810           xi=mod(xi,boxxsize)
14811           if (xi.lt.0) xi=xi+boxxsize
14812           yi=mod(yi,boxysize)
14813           if (yi.lt.0) yi=yi+boxysize
14814           zi=mod(zi,boxzsize)
14815           if (zi.lt.0) zi=zi+boxzsize
14816
14817         do iint=1,nscp_gr(i)
14818
14819         do j=iscpstart(i,iint),iscpend(i,iint)
14820           itypj=itype(j)
14821           if (itypj.eq.ntyp1) cycle
14822 ! Uncomment following three lines for SC-p interactions
14823 !         xj=c(1,nres+j)-xi
14824 !         yj=c(2,nres+j)-yi
14825 !         zj=c(3,nres+j)-zi
14826 ! Uncomment following three lines for Ca-p interactions
14827           xj=c(1,j)
14828           yj=c(2,j)
14829           zj=c(3,j)
14830           xj=mod(xj,boxxsize)
14831           if (xj.lt.0) xj=xj+boxxsize
14832           yj=mod(yj,boxysize)
14833           if (yj.lt.0) yj=yj+boxysize
14834           zj=mod(zj,boxzsize)
14835           if (zj.lt.0) zj=zj+boxzsize
14836       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14837       xj_safe=xj
14838       yj_safe=yj
14839       zj_safe=zj
14840       subchap=0
14841       do xshift=-1,1
14842       do yshift=-1,1
14843       do zshift=-1,1
14844           xj=xj_safe+xshift*boxxsize
14845           yj=yj_safe+yshift*boxysize
14846           zj=zj_safe+zshift*boxzsize
14847           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14848           if(dist_temp.lt.dist_init) then
14849             dist_init=dist_temp
14850             xj_temp=xj
14851             yj_temp=yj
14852             zj_temp=zj
14853             subchap=1
14854           endif
14855        enddo
14856        enddo
14857        enddo
14858        if (subchap.eq.1) then
14859           xj=xj_temp-xi
14860           yj=yj_temp-yi
14861           zj=zj_temp-zi
14862        else
14863           xj=xj_safe-xi
14864           yj=yj_safe-yi
14865           zj=zj_safe-zi
14866        endif
14867           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14868
14869           rij=dsqrt(1.0d0/rrij)
14870             sss_ele_cut=sscale_ele(rij)
14871             sss_ele_grad=sscagrad_ele(rij)
14872 !            print *,sss_ele_cut,sss_ele_grad,&
14873 !            (rij),r_cut_ele,rlamb_ele
14874             if (sss_ele_cut.le.0.0) cycle
14875           sss=sscale((rij/rscp(itypj,iteli)))
14876           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
14877           if (sss.lt.1.0d0) then
14878
14879             fac=rrij**expon2
14880             e1=fac*fac*aad(itypj,iteli)
14881             e2=fac*bad(itypj,iteli)
14882             if (iabs(j-i) .le. 2) then
14883               e1=scal14*e1
14884               e2=scal14*e2
14885               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
14886             endif
14887             evdwij=e1+e2
14888             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
14889             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
14890                 'evdw2',i,j,sss,evdwij
14891 !
14892 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
14893 !
14894             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
14895             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
14896             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
14897             ggg(1)=xj*fac
14898             ggg(2)=yj*fac
14899             ggg(3)=zj*fac
14900 ! Uncomment following three lines for SC-p interactions
14901 !           do k=1,3
14902 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14903 !           enddo
14904 ! Uncomment following line for SC-p interactions
14905 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14906             do k=1,3
14907               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
14908               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
14909             enddo
14910           endif
14911         enddo
14912
14913         enddo ! iint
14914       enddo ! i
14915       do i=1,nct
14916         do j=1,3
14917           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
14918           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
14919           gradx_scp(j,i)=expon*gradx_scp(j,i)
14920         enddo
14921       enddo
14922 !******************************************************************************
14923 !
14924 !                              N O T E !!!
14925 !
14926 ! To save time the factor EXPON has been extracted from ALL components
14927 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14928 ! use!
14929 !
14930 !******************************************************************************
14931       return
14932       end subroutine escp_long
14933 !-----------------------------------------------------------------------------
14934       subroutine escp_short(evdw2,evdw2_14)
14935 !
14936 ! This subroutine calculates the excluded-volume interaction energy between
14937 ! peptide-group centers and side chains and its gradient in virtual-bond and
14938 ! side-chain vectors.
14939 !
14940 !      implicit real*8 (a-h,o-z)
14941 !      include 'DIMENSIONS'
14942 !      include 'COMMON.GEO'
14943 !      include 'COMMON.VAR'
14944 !      include 'COMMON.LOCAL'
14945 !      include 'COMMON.CHAIN'
14946 !      include 'COMMON.DERIV'
14947 !      include 'COMMON.INTERACT'
14948 !      include 'COMMON.FFIELD'
14949 !      include 'COMMON.IOUNITS'
14950 !      include 'COMMON.CONTROL'
14951       real(kind=8),dimension(3) :: ggg
14952 !el local variables
14953       integer :: i,iint,j,k,iteli,itypj,subchap
14954       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
14955       real(kind=8) :: evdw2,evdw2_14,evdwij
14956       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14957                     dist_temp, dist_init
14958
14959       evdw2=0.0D0
14960       evdw2_14=0.0d0
14961 !d    print '(a)','Enter ESCP'
14962 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
14963       do i=iatscp_s,iatscp_e
14964         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
14965         iteli=itel(i)
14966         xi=0.5D0*(c(1,i)+c(1,i+1))
14967         yi=0.5D0*(c(2,i)+c(2,i+1))
14968         zi=0.5D0*(c(3,i)+c(3,i+1))
14969           xi=mod(xi,boxxsize)
14970           if (xi.lt.0) xi=xi+boxxsize
14971           yi=mod(yi,boxysize)
14972           if (yi.lt.0) yi=yi+boxysize
14973           zi=mod(zi,boxzsize)
14974           if (zi.lt.0) zi=zi+boxzsize
14975
14976         do iint=1,nscp_gr(i)
14977
14978         do j=iscpstart(i,iint),iscpend(i,iint)
14979           itypj=itype(j)
14980           if (itypj.eq.ntyp1) cycle
14981 ! Uncomment following three lines for SC-p interactions
14982 !         xj=c(1,nres+j)-xi
14983 !         yj=c(2,nres+j)-yi
14984 !         zj=c(3,nres+j)-zi
14985 ! Uncomment following three lines for Ca-p interactions
14986 !          xj=c(1,j)-xi
14987 !          yj=c(2,j)-yi
14988 !          zj=c(3,j)-zi
14989           xj=c(1,j)
14990           yj=c(2,j)
14991           zj=c(3,j)
14992           xj=mod(xj,boxxsize)
14993           if (xj.lt.0) xj=xj+boxxsize
14994           yj=mod(yj,boxysize)
14995           if (yj.lt.0) yj=yj+boxysize
14996           zj=mod(zj,boxzsize)
14997           if (zj.lt.0) zj=zj+boxzsize
14998       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14999       xj_safe=xj
15000       yj_safe=yj
15001       zj_safe=zj
15002       subchap=0
15003       do xshift=-1,1
15004       do yshift=-1,1
15005       do zshift=-1,1
15006           xj=xj_safe+xshift*boxxsize
15007           yj=yj_safe+yshift*boxysize
15008           zj=zj_safe+zshift*boxzsize
15009           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15010           if(dist_temp.lt.dist_init) then
15011             dist_init=dist_temp
15012             xj_temp=xj
15013             yj_temp=yj
15014             zj_temp=zj
15015             subchap=1
15016           endif
15017        enddo
15018        enddo
15019        enddo
15020        if (subchap.eq.1) then
15021           xj=xj_temp-xi
15022           yj=yj_temp-yi
15023           zj=zj_temp-zi
15024        else
15025           xj=xj_safe-xi
15026           yj=yj_safe-yi
15027           zj=zj_safe-zi
15028        endif
15029
15030           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15031           rij=dsqrt(1.0d0/rrij)
15032             sss_ele_cut=sscale_ele(rij)
15033             sss_ele_grad=sscagrad_ele(rij)
15034 !            print *,sss_ele_cut,sss_ele_grad,&
15035 !            (rij),r_cut_ele,rlamb_ele
15036             if (sss_ele_cut.le.0.0) cycle
15037           sss=sscale(rij/rscp(itypj,iteli))
15038           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15039           if (sss.gt.0.0d0) then
15040
15041             fac=rrij**expon2
15042             e1=fac*fac*aad(itypj,iteli)
15043             e2=fac*bad(itypj,iteli)
15044             if (iabs(j-i) .le. 2) then
15045               e1=scal14*e1
15046               e2=scal14*e2
15047               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15048             endif
15049             evdwij=e1+e2
15050             evdw2=evdw2+evdwij*sss*sss_ele_cut
15051             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15052                 'evdw2',i,j,sss,evdwij
15053 !
15054 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15055 !
15056             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15057             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15058             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15059
15060             ggg(1)=xj*fac
15061             ggg(2)=yj*fac
15062             ggg(3)=zj*fac
15063 ! Uncomment following three lines for SC-p interactions
15064 !           do k=1,3
15065 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15066 !           enddo
15067 ! Uncomment following line for SC-p interactions
15068 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15069             do k=1,3
15070               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15071               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15072             enddo
15073           endif
15074         enddo
15075
15076         enddo ! iint
15077       enddo ! i
15078       do i=1,nct
15079         do j=1,3
15080           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15081           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15082           gradx_scp(j,i)=expon*gradx_scp(j,i)
15083         enddo
15084       enddo
15085 !******************************************************************************
15086 !
15087 !                              N O T E !!!
15088 !
15089 ! To save time the factor EXPON has been extracted from ALL components
15090 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15091 ! use!
15092 !
15093 !******************************************************************************
15094       return
15095       end subroutine escp_short
15096 !-----------------------------------------------------------------------------
15097 ! energy_p_new-sep_barrier.F
15098 !-----------------------------------------------------------------------------
15099       subroutine sc_grad_scale(scalfac)
15100 !      implicit real*8 (a-h,o-z)
15101       use calc_data
15102 !      include 'DIMENSIONS'
15103 !      include 'COMMON.CHAIN'
15104 !      include 'COMMON.DERIV'
15105 !      include 'COMMON.CALC'
15106 !      include 'COMMON.IOUNITS'
15107       real(kind=8),dimension(3) :: dcosom1,dcosom2
15108       real(kind=8) :: scalfac
15109 !el local variables
15110 !      integer :: i,j,k,l
15111
15112       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15113       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15114       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15115            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15116 ! diagnostics only
15117 !      eom1=0.0d0
15118 !      eom2=0.0d0
15119 !      eom12=evdwij*eps1_om12
15120 ! end diagnostics
15121 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15122 !     &  " sigder",sigder
15123 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15124 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15125       do k=1,3
15126         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15127         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15128       enddo
15129       do k=1,3
15130         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15131          *sss_ele_cut
15132       enddo
15133 !      write (iout,*) "gg",(gg(k),k=1,3)
15134       do k=1,3
15135         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15136                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15137                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15138                  *sss_ele_cut
15139         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15140                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15141                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15142          *sss_ele_cut
15143 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15144 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15145 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15146 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15147       enddo
15148 !
15149 ! Calculate the components of the gradient in DC and X
15150 !
15151       do l=1,3
15152         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15153         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15154       enddo
15155       return
15156       end subroutine sc_grad_scale
15157 !-----------------------------------------------------------------------------
15158 ! energy_split-sep.F
15159 !-----------------------------------------------------------------------------
15160       subroutine etotal_long(energia)
15161 !
15162 ! Compute the long-range slow-varying contributions to the energy
15163 !
15164 !      implicit real*8 (a-h,o-z)
15165 !      include 'DIMENSIONS'
15166       use MD_data, only: totT,usampl,eq_time
15167 #ifndef ISNAN
15168       external proc_proc
15169 #ifdef WINPGI
15170 !MS$ATTRIBUTES C ::  proc_proc
15171 #endif
15172 #endif
15173 #ifdef MPI
15174       include "mpif.h"
15175       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15176 #endif
15177 !      include 'COMMON.SETUP'
15178 !      include 'COMMON.IOUNITS'
15179 !      include 'COMMON.FFIELD'
15180 !      include 'COMMON.DERIV'
15181 !      include 'COMMON.INTERACT'
15182 !      include 'COMMON.SBRIDGE'
15183 !      include 'COMMON.CHAIN'
15184 !      include 'COMMON.VAR'
15185 !      include 'COMMON.LOCAL'
15186 !      include 'COMMON.MD'
15187       real(kind=8),dimension(0:n_ene) :: energia
15188 !el local variables
15189       integer :: i,n_corr,n_corr1,ierror,ierr
15190       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15191                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15192                   ecorr,ecorr5,ecorr6,eturn6,time00
15193 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15194 !elwrite(iout,*)"in etotal long"
15195
15196       if (modecalc.eq.12.or.modecalc.eq.14) then
15197 #ifdef MPI
15198 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15199 #else
15200         call int_from_cart1(.false.)
15201 #endif
15202       endif
15203 !elwrite(iout,*)"in etotal long"
15204
15205 #ifdef MPI
15206 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15207 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15208       call flush(iout)
15209       if (nfgtasks.gt.1) then
15210         time00=MPI_Wtime()
15211 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15212         if (fg_rank.eq.0) then
15213           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15214 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15215 !          call flush(iout)
15216 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15217 ! FG slaves as WEIGHTS array.
15218           weights_(1)=wsc
15219           weights_(2)=wscp
15220           weights_(3)=welec
15221           weights_(4)=wcorr
15222           weights_(5)=wcorr5
15223           weights_(6)=wcorr6
15224           weights_(7)=wel_loc
15225           weights_(8)=wturn3
15226           weights_(9)=wturn4
15227           weights_(10)=wturn6
15228           weights_(11)=wang
15229           weights_(12)=wscloc
15230           weights_(13)=wtor
15231           weights_(14)=wtor_d
15232           weights_(15)=wstrain
15233           weights_(16)=wvdwpp
15234           weights_(17)=wbond
15235           weights_(18)=scal14
15236           weights_(21)=wsccor
15237 ! FG Master broadcasts the WEIGHTS_ array
15238           call MPI_Bcast(weights_(1),n_ene,&
15239               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15240         else
15241 ! FG slaves receive the WEIGHTS array
15242           call MPI_Bcast(weights(1),n_ene,&
15243               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15244           wsc=weights(1)
15245           wscp=weights(2)
15246           welec=weights(3)
15247           wcorr=weights(4)
15248           wcorr5=weights(5)
15249           wcorr6=weights(6)
15250           wel_loc=weights(7)
15251           wturn3=weights(8)
15252           wturn4=weights(9)
15253           wturn6=weights(10)
15254           wang=weights(11)
15255           wscloc=weights(12)
15256           wtor=weights(13)
15257           wtor_d=weights(14)
15258           wstrain=weights(15)
15259           wvdwpp=weights(16)
15260           wbond=weights(17)
15261           scal14=weights(18)
15262           wsccor=weights(21)
15263         endif
15264         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15265           king,FG_COMM,IERR)
15266          time_Bcast=time_Bcast+MPI_Wtime()-time00
15267          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15268 !        call chainbuild_cart
15269 !        call int_from_cart1(.false.)
15270       endif
15271 !      write (iout,*) 'Processor',myrank,
15272 !     &  ' calling etotal_short ipot=',ipot
15273 !      call flush(iout)
15274 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15275 #endif
15276 !d    print *,'nnt=',nnt,' nct=',nct
15277 !
15278 !elwrite(iout,*)"in etotal long"
15279 ! Compute the side-chain and electrostatic interaction energy
15280 !
15281       goto (101,102,103,104,105,106) ipot
15282 ! Lennard-Jones potential.
15283   101 call elj_long(evdw)
15284 !d    print '(a)','Exit ELJ'
15285       goto 107
15286 ! Lennard-Jones-Kihara potential (shifted).
15287   102 call eljk_long(evdw)
15288       goto 107
15289 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15290   103 call ebp_long(evdw)
15291       goto 107
15292 ! Gay-Berne potential (shifted LJ, angular dependence).
15293   104 call egb_long(evdw)
15294       goto 107
15295 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15296   105 call egbv_long(evdw)
15297       goto 107
15298 ! Soft-sphere potential
15299   106 call e_softsphere(evdw)
15300 !
15301 ! Calculate electrostatic (H-bonding) energy of the main chain.
15302 !
15303   107 continue
15304       call vec_and_deriv
15305       if (ipot.lt.6) then
15306 #ifdef SPLITELE
15307          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15308              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15309              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15310              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15311 #else
15312          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15313              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15314              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15315              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15316 #endif
15317            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15318          else
15319             ees=0
15320             evdw1=0
15321             eel_loc=0
15322             eello_turn3=0
15323             eello_turn4=0
15324          endif
15325       else
15326 !        write (iout,*) "Soft-spheer ELEC potential"
15327         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15328          eello_turn4)
15329       endif
15330 !
15331 ! Calculate excluded-volume interaction energy between peptide groups
15332 ! and side chains.
15333 !
15334       if (ipot.lt.6) then
15335        if(wscp.gt.0d0) then
15336         call escp_long(evdw2,evdw2_14)
15337        else
15338         evdw2=0
15339         evdw2_14=0
15340        endif
15341       else
15342         call escp_soft_sphere(evdw2,evdw2_14)
15343       endif
15344 !
15345 ! 12/1/95 Multi-body terms
15346 !
15347       n_corr=0
15348       n_corr1=0
15349       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15350           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15351          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15352 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15353 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15354       else
15355          ecorr=0.0d0
15356          ecorr5=0.0d0
15357          ecorr6=0.0d0
15358          eturn6=0.0d0
15359       endif
15360       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15361          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15362       endif
15363 !
15364 ! If performing constraint dynamics, call the constraint energy
15365 !  after the equilibration time
15366       if(usampl.and.totT.gt.eq_time) then
15367          call EconstrQ
15368          call Econstr_back
15369       else
15370          Uconst=0.0d0
15371          Uconst_back=0.0d0
15372       endif
15373 !
15374 ! Sum the energies
15375 !
15376       do i=1,n_ene
15377         energia(i)=0.0d0
15378       enddo
15379       energia(1)=evdw
15380 #ifdef SCP14
15381       energia(2)=evdw2-evdw2_14
15382       energia(18)=evdw2_14
15383 #else
15384       energia(2)=evdw2
15385       energia(18)=0.0d0
15386 #endif
15387 #ifdef SPLITELE
15388       energia(3)=ees
15389       energia(16)=evdw1
15390 #else
15391       energia(3)=ees+evdw1
15392       energia(16)=0.0d0
15393 #endif
15394       energia(4)=ecorr
15395       energia(5)=ecorr5
15396       energia(6)=ecorr6
15397       energia(7)=eel_loc
15398       energia(8)=eello_turn3
15399       energia(9)=eello_turn4
15400       energia(10)=eturn6
15401       energia(20)=Uconst+Uconst_back
15402       call sum_energy(energia,.true.)
15403 !      write (iout,*) "Exit ETOTAL_LONG"
15404       call flush(iout)
15405       return
15406       end subroutine etotal_long
15407 !-----------------------------------------------------------------------------
15408       subroutine etotal_short(energia)
15409 !
15410 ! Compute the short-range fast-varying contributions to the energy
15411 !
15412 !      implicit real*8 (a-h,o-z)
15413 !      include 'DIMENSIONS'
15414 #ifndef ISNAN
15415       external proc_proc
15416 #ifdef WINPGI
15417 !MS$ATTRIBUTES C ::  proc_proc
15418 #endif
15419 #endif
15420 #ifdef MPI
15421       include "mpif.h"
15422       integer :: ierror,ierr
15423       real(kind=8),dimension(n_ene) :: weights_
15424       real(kind=8) :: time00
15425 #endif
15426 !      include 'COMMON.SETUP'
15427 !      include 'COMMON.IOUNITS'
15428 !      include 'COMMON.FFIELD'
15429 !      include 'COMMON.DERIV'
15430 !      include 'COMMON.INTERACT'
15431 !      include 'COMMON.SBRIDGE'
15432 !      include 'COMMON.CHAIN'
15433 !      include 'COMMON.VAR'
15434 !      include 'COMMON.LOCAL'
15435       real(kind=8),dimension(0:n_ene) :: energia
15436 !el local variables
15437       integer :: i,nres6
15438       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15439       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15440       nres6=6*nres
15441
15442 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15443 !      call flush(iout)
15444       if (modecalc.eq.12.or.modecalc.eq.14) then
15445 #ifdef MPI
15446         if (fg_rank.eq.0) call int_from_cart1(.false.)
15447 #else
15448         call int_from_cart1(.false.)
15449 #endif
15450       endif
15451 #ifdef MPI
15452 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15453 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15454 !      call flush(iout)
15455       if (nfgtasks.gt.1) then
15456         time00=MPI_Wtime()
15457 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15458         if (fg_rank.eq.0) then
15459           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15460 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15461 !          call flush(iout)
15462 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15463 ! FG slaves as WEIGHTS array.
15464           weights_(1)=wsc
15465           weights_(2)=wscp
15466           weights_(3)=welec
15467           weights_(4)=wcorr
15468           weights_(5)=wcorr5
15469           weights_(6)=wcorr6
15470           weights_(7)=wel_loc
15471           weights_(8)=wturn3
15472           weights_(9)=wturn4
15473           weights_(10)=wturn6
15474           weights_(11)=wang
15475           weights_(12)=wscloc
15476           weights_(13)=wtor
15477           weights_(14)=wtor_d
15478           weights_(15)=wstrain
15479           weights_(16)=wvdwpp
15480           weights_(17)=wbond
15481           weights_(18)=scal14
15482           weights_(21)=wsccor
15483 ! FG Master broadcasts the WEIGHTS_ array
15484           call MPI_Bcast(weights_(1),n_ene,&
15485               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15486         else
15487 ! FG slaves receive the WEIGHTS array
15488           call MPI_Bcast(weights(1),n_ene,&
15489               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15490           wsc=weights(1)
15491           wscp=weights(2)
15492           welec=weights(3)
15493           wcorr=weights(4)
15494           wcorr5=weights(5)
15495           wcorr6=weights(6)
15496           wel_loc=weights(7)
15497           wturn3=weights(8)
15498           wturn4=weights(9)
15499           wturn6=weights(10)
15500           wang=weights(11)
15501           wscloc=weights(12)
15502           wtor=weights(13)
15503           wtor_d=weights(14)
15504           wstrain=weights(15)
15505           wvdwpp=weights(16)
15506           wbond=weights(17)
15507           scal14=weights(18)
15508           wsccor=weights(21)
15509         endif
15510 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15511         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15512           king,FG_COMM,IERR)
15513 !        write (iout,*) "Processor",myrank," BROADCAST c"
15514         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15515           king,FG_COMM,IERR)
15516 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15517         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15518           king,FG_COMM,IERR)
15519 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15520         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15521           king,FG_COMM,IERR)
15522 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15523         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15524           king,FG_COMM,IERR)
15525 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15526         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15527           king,FG_COMM,IERR)
15528 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15529         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15530           king,FG_COMM,IERR)
15531 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15532         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15533           king,FG_COMM,IERR)
15534 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15535         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15536           king,FG_COMM,IERR)
15537          time_Bcast=time_Bcast+MPI_Wtime()-time00
15538 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15539       endif
15540 !      write (iout,*) 'Processor',myrank,
15541 !     &  ' calling etotal_short ipot=',ipot
15542 !      call flush(iout)
15543 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15544 #endif
15545 !      call int_from_cart1(.false.)
15546 !
15547 ! Compute the side-chain and electrostatic interaction energy
15548 !
15549       goto (101,102,103,104,105,106) ipot
15550 ! Lennard-Jones potential.
15551   101 call elj_short(evdw)
15552 !d    print '(a)','Exit ELJ'
15553       goto 107
15554 ! Lennard-Jones-Kihara potential (shifted).
15555   102 call eljk_short(evdw)
15556       goto 107
15557 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15558   103 call ebp_short(evdw)
15559       goto 107
15560 ! Gay-Berne potential (shifted LJ, angular dependence).
15561   104 call egb_short(evdw)
15562       goto 107
15563 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15564   105 call egbv_short(evdw)
15565       goto 107
15566 ! Soft-sphere potential - already dealt with in the long-range part
15567   106 evdw=0.0d0
15568 !  106 call e_softsphere_short(evdw)
15569 !
15570 ! Calculate electrostatic (H-bonding) energy of the main chain.
15571 !
15572   107 continue
15573 !
15574 ! Calculate the short-range part of Evdwpp
15575 !
15576       call evdwpp_short(evdw1)
15577 !
15578 ! Calculate the short-range part of ESCp
15579 !
15580       if (ipot.lt.6) then
15581         call escp_short(evdw2,evdw2_14)
15582       endif
15583 !
15584 ! Calculate the bond-stretching energy
15585 !
15586       call ebond(estr)
15587 !
15588 ! Calculate the disulfide-bridge and other energy and the contributions
15589 ! from other distance constraints.
15590       call edis(ehpb)
15591 !
15592 ! Calculate the virtual-bond-angle energy.
15593 !
15594       call ebend(ebe,ethetacnstr)
15595 !
15596 ! Calculate the SC local energy.
15597 !
15598       call vec_and_deriv
15599       call esc(escloc)
15600 !
15601 ! Calculate the virtual-bond torsional energy.
15602 !
15603       call etor(etors,edihcnstr)
15604 !
15605 ! 6/23/01 Calculate double-torsional energy
15606 !
15607       call etor_d(etors_d)
15608 !
15609 ! 21/5/07 Calculate local sicdechain correlation energy
15610 !
15611       if (wsccor.gt.0.0d0) then
15612         call eback_sc_corr(esccor)
15613       else
15614         esccor=0.0d0
15615       endif
15616 !
15617 ! Put energy components into an array
15618 !
15619       do i=1,n_ene
15620         energia(i)=0.0d0
15621       enddo
15622       energia(1)=evdw
15623 #ifdef SCP14
15624       energia(2)=evdw2-evdw2_14
15625       energia(18)=evdw2_14
15626 #else
15627       energia(2)=evdw2
15628       energia(18)=0.0d0
15629 #endif
15630 #ifdef SPLITELE
15631       energia(16)=evdw1
15632 #else
15633       energia(3)=evdw1
15634 #endif
15635       energia(11)=ebe
15636       energia(12)=escloc
15637       energia(13)=etors
15638       energia(14)=etors_d
15639       energia(15)=ehpb
15640       energia(17)=estr
15641       energia(19)=edihcnstr
15642       energia(21)=esccor
15643 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15644       call flush(iout)
15645       call sum_energy(energia,.true.)
15646 !      write (iout,*) "Exit ETOTAL_SHORT"
15647       call flush(iout)
15648       return
15649       end subroutine etotal_short
15650 !-----------------------------------------------------------------------------
15651 ! gnmr1.f
15652 !-----------------------------------------------------------------------------
15653       real(kind=8) function gnmr1(y,ymin,ymax)
15654 !      implicit none
15655       real(kind=8) :: y,ymin,ymax
15656       real(kind=8) :: wykl=4.0d0
15657       if (y.lt.ymin) then
15658         gnmr1=(ymin-y)**wykl/wykl
15659       else if (y.gt.ymax) then
15660         gnmr1=(y-ymax)**wykl/wykl
15661       else
15662         gnmr1=0.0d0
15663       endif
15664       return
15665       end function gnmr1
15666 !-----------------------------------------------------------------------------
15667       real(kind=8) function gnmr1prim(y,ymin,ymax)
15668 !      implicit none
15669       real(kind=8) :: y,ymin,ymax
15670       real(kind=8) :: wykl=4.0d0
15671       if (y.lt.ymin) then
15672         gnmr1prim=-(ymin-y)**(wykl-1)
15673       else if (y.gt.ymax) then
15674         gnmr1prim=(y-ymax)**(wykl-1)
15675       else
15676         gnmr1prim=0.0d0
15677       endif
15678       return
15679       end function gnmr1prim
15680 !----------------------------------------------------------------------------
15681       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
15682       real(kind=8) y,ymin,ymax,sigma
15683       real(kind=8) wykl /4.0d0/
15684       if (y.lt.ymin) then
15685         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
15686       else if (y.gt.ymax) then
15687         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
15688       else
15689         rlornmr1=0.0d0
15690       endif
15691       return
15692       end function rlornmr1
15693 !------------------------------------------------------------------------------
15694       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
15695       real(kind=8) y,ymin,ymax,sigma
15696       real(kind=8) wykl /4.0d0/
15697       if (y.lt.ymin) then
15698         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
15699         ((ymin-y)**wykl+sigma**wykl)**2
15700       else if (y.gt.ymax) then
15701         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
15702         ((y-ymax)**wykl+sigma**wykl)**2
15703       else
15704         rlornmr1prim=0.0d0
15705       endif
15706       return
15707       end function rlornmr1prim
15708
15709       real(kind=8) function harmonic(y,ymax)
15710 !      implicit none
15711       real(kind=8) :: y,ymax
15712       real(kind=8) :: wykl=2.0d0
15713       harmonic=(y-ymax)**wykl
15714       return
15715       end function harmonic
15716 !-----------------------------------------------------------------------------
15717       real(kind=8) function harmonicprim(y,ymax)
15718       real(kind=8) :: y,ymin,ymax
15719       real(kind=8) :: wykl=2.0d0
15720       harmonicprim=(y-ymax)*wykl
15721       return
15722       end function harmonicprim
15723 !-----------------------------------------------------------------------------
15724 ! gradient_p.F
15725 !-----------------------------------------------------------------------------
15726       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
15727
15728       use io_base, only:intout,briefout
15729 !      implicit real*8 (a-h,o-z)
15730 !      include 'DIMENSIONS'
15731 !      include 'COMMON.CHAIN'
15732 !      include 'COMMON.DERIV'
15733 !      include 'COMMON.VAR'
15734 !      include 'COMMON.INTERACT'
15735 !      include 'COMMON.FFIELD'
15736 !      include 'COMMON.MD'
15737 !      include 'COMMON.IOUNITS'
15738       real(kind=8),external :: ufparm
15739       integer :: uiparm(1)
15740       real(kind=8) :: urparm(1)
15741       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
15742       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
15743       integer :: n,nf,ind,ind1,i,k,j
15744 !
15745 ! This subroutine calculates total internal coordinate gradient.
15746 ! Depending on the number of function evaluations, either whole energy
15747 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
15748 ! internal coordinates are reevaluated or only the cartesian-in-internal
15749 ! coordinate derivatives are evaluated. The subroutine was designed to work
15750 ! with SUMSL.
15751 !
15752 !
15753       icg=mod(nf,2)+1
15754
15755 !d      print *,'grad',nf,icg
15756       if (nf-nfl+1) 20,30,40
15757    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
15758 !    write (iout,*) 'grad 20'
15759       if (nf.eq.0) return
15760       goto 40
15761    30 call var_to_geom(n,x)
15762       call chainbuild
15763 !    write (iout,*) 'grad 30'
15764 !
15765 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
15766 !
15767    40 call cartder
15768 !     write (iout,*) 'grad 40'
15769 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
15770 !
15771 ! Convert the Cartesian gradient into internal-coordinate gradient.
15772 !
15773       ind=0
15774       ind1=0
15775       do i=1,nres-2
15776         gthetai=0.0D0
15777         gphii=0.0D0
15778         do j=i+1,nres-1
15779           ind=ind+1
15780 !         ind=indmat(i,j)
15781 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
15782           do k=1,3
15783             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
15784           enddo
15785           do k=1,3
15786             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
15787           enddo
15788         enddo
15789         do j=i+1,nres-1
15790           ind1=ind1+1
15791 !         ind1=indmat(i,j)
15792 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
15793           do k=1,3
15794             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
15795             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
15796           enddo
15797         enddo
15798         if (i.gt.1) g(i-1)=gphii
15799         if (n.gt.nphi) g(nphi+i)=gthetai
15800       enddo
15801       if (n.le.nphi+ntheta) goto 10
15802       do i=2,nres-1
15803         if (itype(i).ne.10) then
15804           galphai=0.0D0
15805           gomegai=0.0D0
15806           do k=1,3
15807             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
15808           enddo
15809           do k=1,3
15810             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
15811           enddo
15812           g(ialph(i,1))=galphai
15813           g(ialph(i,1)+nside)=gomegai
15814         endif
15815       enddo
15816 !
15817 ! Add the components corresponding to local energy terms.
15818 !
15819    10 continue
15820       do i=1,nvar
15821 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
15822         g(i)=g(i)+gloc(i,icg)
15823       enddo
15824 ! Uncomment following three lines for diagnostics.
15825 !d    call intout
15826 !elwrite(iout,*) "in gradient after calling intout"
15827 !d    call briefout(0,0.0d0)
15828 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
15829       return
15830       end subroutine gradient
15831 !-----------------------------------------------------------------------------
15832       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
15833
15834       use comm_chu
15835 !      implicit real*8 (a-h,o-z)
15836 !      include 'DIMENSIONS'
15837 !      include 'COMMON.DERIV'
15838 !      include 'COMMON.IOUNITS'
15839 !      include 'COMMON.GEO'
15840       integer :: n,nf
15841 !el      integer :: jjj
15842 !el      common /chuju/ jjj
15843       real(kind=8) :: energia(0:n_ene)
15844       integer :: uiparm(1)
15845       real(kind=8) :: urparm(1)
15846       real(kind=8) :: f
15847       real(kind=8),external :: ufparm
15848       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
15849 !     if (jjj.gt.0) then
15850 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15851 !     endif
15852       nfl=nf
15853       icg=mod(nf,2)+1
15854 !d      print *,'func',nf,nfl,icg
15855       call var_to_geom(n,x)
15856       call zerograd
15857       call chainbuild
15858 !d    write (iout,*) 'ETOTAL called from FUNC'
15859       call etotal(energia)
15860       call sum_gradient
15861       f=energia(0)
15862 !     if (jjj.gt.0) then
15863 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15864 !       write (iout,*) 'f=',etot
15865 !       jjj=0
15866 !     endif
15867       return
15868       end subroutine func
15869 !-----------------------------------------------------------------------------
15870       subroutine cartgrad
15871 !      implicit real*8 (a-h,o-z)
15872 !      include 'DIMENSIONS'
15873       use energy_data
15874       use MD_data, only: totT,usampl,eq_time
15875 #ifdef MPI
15876       include 'mpif.h'
15877 #endif
15878 !      include 'COMMON.CHAIN'
15879 !      include 'COMMON.DERIV'
15880 !      include 'COMMON.VAR'
15881 !      include 'COMMON.INTERACT'
15882 !      include 'COMMON.FFIELD'
15883 !      include 'COMMON.MD'
15884 !      include 'COMMON.IOUNITS'
15885 !      include 'COMMON.TIME1'
15886 !
15887       integer :: i,j
15888
15889 ! This subrouting calculates total Cartesian coordinate gradient.
15890 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
15891 !
15892 !el#define DEBUG
15893 #ifdef TIMING
15894       time00=MPI_Wtime()
15895 #endif
15896       icg=1
15897       call sum_gradient
15898 #ifdef TIMING
15899 #endif
15900 !el      write (iout,*) "After sum_gradient"
15901 #ifdef DEBUG
15902 !el      write (iout,*) "After sum_gradient"
15903       do i=1,nres-1
15904         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
15905         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
15906       enddo
15907 #endif
15908 ! If performing constraint dynamics, add the gradients of the constraint energy
15909       if(usampl.and.totT.gt.eq_time) then
15910          do i=1,nct
15911            do j=1,3
15912              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
15913              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
15914            enddo
15915          enddo
15916          do i=1,nres-3
15917            gloc(i,icg)=gloc(i,icg)+dugamma(i)
15918          enddo
15919          do i=1,nres-2
15920            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
15921          enddo
15922       endif
15923 !elwrite (iout,*) "After sum_gradient"
15924 #ifdef TIMING
15925       time01=MPI_Wtime()
15926 #endif
15927       call intcartderiv
15928 !elwrite (iout,*) "After sum_gradient"
15929 #ifdef TIMING
15930       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
15931 #endif
15932 !     call checkintcartgrad
15933 !     write(iout,*) 'calling int_to_cart'
15934 #ifdef DEBUG
15935       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
15936 #endif
15937       do i=0,nct
15938         do j=1,3
15939           gcart(j,i)=gradc(j,i,icg)
15940           gxcart(j,i)=gradx(j,i,icg)
15941         enddo
15942 #ifdef DEBUG
15943         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
15944           (gxcart(j,i),j=1,3),gloc(i,icg)
15945 #endif
15946       enddo
15947 #ifdef TIMING
15948       time01=MPI_Wtime()
15949 #endif
15950       call int_to_cart
15951 #ifdef TIMING
15952       time_inttocart=time_inttocart+MPI_Wtime()-time01
15953 #endif
15954 #ifdef DEBUG
15955       write (iout,*) "gcart and gxcart after int_to_cart"
15956       do i=0,nres-1
15957         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
15958             (gxcart(j,i),j=1,3)
15959       enddo
15960 #endif
15961 #ifdef CARGRAD
15962 #ifdef DEBUG
15963       write (iout,*) "CARGRAD"
15964 #endif
15965       do i=nres,0,-1
15966         do j=1,3
15967           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
15968 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
15969         enddo
15970 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
15971 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
15972       enddo
15973 ! Correction: dummy residues
15974         if (nnt.gt.1) then
15975           do j=1,3
15976 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
15977             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
15978           enddo
15979         endif
15980         if (nct.lt.nres) then
15981           do j=1,3
15982 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
15983             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
15984           enddo
15985         endif
15986 #endif
15987 #ifdef TIMING
15988       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
15989 #endif
15990 !el#undef DEBUG
15991       return
15992       end subroutine cartgrad
15993 !-----------------------------------------------------------------------------
15994       subroutine zerograd
15995 !      implicit real*8 (a-h,o-z)
15996 !      include 'DIMENSIONS'
15997 !      include 'COMMON.DERIV'
15998 !      include 'COMMON.CHAIN'
15999 !      include 'COMMON.VAR'
16000 !      include 'COMMON.MD'
16001 !      include 'COMMON.SCCOR'
16002 !
16003 !el local variables
16004       integer :: i,j,intertyp,k
16005 ! Initialize Cartesian-coordinate gradient
16006 !
16007 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16008 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16009
16010 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16011 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16012 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16013 !      allocate(gradcorr_long(3,nres))
16014 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16015 !      allocate(gcorr6_turn_long(3,nres))
16016 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16017
16018 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16019
16020 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16021 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16022
16023 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16024 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16025
16026 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16027 !      allocate(gscloc(3,nres)) !(3,maxres)
16028 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16029
16030
16031
16032 !      common /deriv_scloc/
16033 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16034 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16035 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
16036 !      common /mpgrad/
16037 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16038
16039
16040
16041 !          gradc(j,i,icg)=0.0d0
16042 !          gradx(j,i,icg)=0.0d0
16043
16044 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16045 !elwrite(iout,*) "icg",icg
16046       do i=-1,nres
16047         do j=1,3
16048           gvdwx(j,i)=0.0D0
16049           gradx_scp(j,i)=0.0D0
16050           gvdwc(j,i)=0.0D0
16051           gvdwc_scp(j,i)=0.0D0
16052           gvdwc_scpp(j,i)=0.0d0
16053           gelc(j,i)=0.0D0
16054           gelc_long(j,i)=0.0D0
16055           gradb(j,i)=0.0d0
16056           gradbx(j,i)=0.0d0
16057           gvdwpp(j,i)=0.0d0
16058           gel_loc(j,i)=0.0d0
16059           gel_loc_long(j,i)=0.0d0
16060           ghpbc(j,i)=0.0D0
16061           ghpbx(j,i)=0.0D0
16062           gcorr3_turn(j,i)=0.0d0
16063           gcorr4_turn(j,i)=0.0d0
16064           gradcorr(j,i)=0.0d0
16065           gradcorr_long(j,i)=0.0d0
16066           gradcorr5_long(j,i)=0.0d0
16067           gradcorr6_long(j,i)=0.0d0
16068           gcorr6_turn_long(j,i)=0.0d0
16069           gradcorr5(j,i)=0.0d0
16070           gradcorr6(j,i)=0.0d0
16071           gcorr6_turn(j,i)=0.0d0
16072           gsccorc(j,i)=0.0d0
16073           gsccorx(j,i)=0.0d0
16074           gradc(j,i,icg)=0.0d0
16075           gradx(j,i,icg)=0.0d0
16076           gscloc(j,i)=0.0d0
16077           gsclocx(j,i)=0.0d0
16078           gliptran(j,i)=0.0d0
16079           gliptranx(j,i)=0.0d0
16080           gliptranc(j,i)=0.0d0
16081           gshieldx(j,i)=0.0d0
16082           gshieldc(j,i)=0.0d0
16083           gshieldc_loc(j,i)=0.0d0
16084           gshieldx_ec(j,i)=0.0d0
16085           gshieldc_ec(j,i)=0.0d0
16086           gshieldc_loc_ec(j,i)=0.0d0
16087           gshieldx_t3(j,i)=0.0d0
16088           gshieldc_t3(j,i)=0.0d0
16089           gshieldc_loc_t3(j,i)=0.0d0
16090           gshieldx_t4(j,i)=0.0d0
16091           gshieldc_t4(j,i)=0.0d0
16092           gshieldc_loc_t4(j,i)=0.0d0
16093           gshieldx_ll(j,i)=0.0d0
16094           gshieldc_ll(j,i)=0.0d0
16095           gshieldc_loc_ll(j,i)=0.0d0
16096           gg_tube(j,i)=0.0d0
16097           gg_tube_sc(j,i)=0.0d0
16098           gradafm(j,i)=0.0d0
16099           do intertyp=1,3
16100            gloc_sc(intertyp,i,icg)=0.0d0
16101           enddo
16102         enddo
16103       enddo
16104       do i=1,nres
16105        do j=1,maxcontsshi
16106        shield_list(j,i)=0
16107         do k=1,3
16108 !C           print *,i,j,k
16109            grad_shield_side(k,j,i)=0.0d0
16110            grad_shield_loc(k,j,i)=0.0d0
16111          enddo
16112        enddo
16113        ishield_list(i)=0
16114       enddo
16115
16116 !
16117 ! Initialize the gradient of local energy terms.
16118 !
16119 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
16120 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16121 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16122 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
16123 !      allocate(gel_loc_turn3(nres))
16124 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16125 !      allocate(gsccor_loc(nres))       !(maxres)
16126
16127       do i=1,4*nres
16128         gloc(i,icg)=0.0D0
16129       enddo
16130       do i=1,nres
16131         gel_loc_loc(i)=0.0d0
16132         gcorr_loc(i)=0.0d0
16133         g_corr5_loc(i)=0.0d0
16134         g_corr6_loc(i)=0.0d0
16135         gel_loc_turn3(i)=0.0d0
16136         gel_loc_turn4(i)=0.0d0
16137         gel_loc_turn6(i)=0.0d0
16138         gsccor_loc(i)=0.0d0
16139       enddo
16140 ! initialize gcart and gxcart
16141 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16142       do i=0,nres
16143         do j=1,3
16144           gcart(j,i)=0.0d0
16145           gxcart(j,i)=0.0d0
16146         enddo
16147       enddo
16148       return
16149       end subroutine zerograd
16150 !-----------------------------------------------------------------------------
16151       real(kind=8) function fdum()
16152       fdum=0.0D0
16153       return
16154       end function fdum
16155 !-----------------------------------------------------------------------------
16156 ! intcartderiv.F
16157 !-----------------------------------------------------------------------------
16158       subroutine intcartderiv
16159 !      implicit real*8 (a-h,o-z)
16160 !      include 'DIMENSIONS'
16161 #ifdef MPI
16162       include 'mpif.h'
16163 #endif
16164 !      include 'COMMON.SETUP'
16165 !      include 'COMMON.CHAIN'
16166 !      include 'COMMON.VAR'
16167 !      include 'COMMON.GEO'
16168 !      include 'COMMON.INTERACT'
16169 !      include 'COMMON.DERIV'
16170 !      include 'COMMON.IOUNITS'
16171 !      include 'COMMON.LOCAL'
16172 !      include 'COMMON.SCCOR'
16173       real(kind=8) :: pi4,pi34
16174       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16175       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16176                     dcosomega,dsinomega !(3,3,maxres)
16177       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16178
16179       integer :: i,j,k
16180       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16181                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16182                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16183                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16184       integer :: nres2
16185       nres2=2*nres
16186
16187 !el from module energy-------------
16188 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16189 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16190 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16191
16192 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16193 !el      allocate(dsintau(3,3,3,0:nres2))
16194 !el      allocate(dtauangle(3,3,3,0:nres2))
16195 !el      allocate(domicron(3,2,2,0:nres2))
16196 !el      allocate(dcosomicron(3,2,2,0:nres2))
16197
16198
16199
16200 #if defined(MPI) && defined(PARINTDER)
16201       if (nfgtasks.gt.1 .and. me.eq.king) &
16202         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16203 #endif
16204       pi4 = 0.5d0*pipol
16205       pi34 = 3*pi4
16206
16207 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
16208 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16209
16210 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16211       do i=1,nres
16212         do j=1,3
16213           dtheta(j,1,i)=0.0d0
16214           dtheta(j,2,i)=0.0d0
16215           dphi(j,1,i)=0.0d0
16216           dphi(j,2,i)=0.0d0
16217           dphi(j,3,i)=0.0d0
16218         enddo
16219       enddo
16220 ! Derivatives of theta's
16221 #if defined(MPI) && defined(PARINTDER)
16222 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16223       do i=max0(ithet_start-1,3),ithet_end
16224 #else
16225       do i=3,nres
16226 #endif
16227         cost=dcos(theta(i))
16228         sint=sqrt(1-cost*cost)
16229         do j=1,3
16230           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16231           vbld(i-1)
16232           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16233           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16234           vbld(i)
16235           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16236         enddo
16237       enddo
16238 #if defined(MPI) && defined(PARINTDER)
16239 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16240       do i=max0(ithet_start-1,3),ithet_end
16241 #else
16242       do i=3,nres
16243 #endif
16244       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
16245         cost1=dcos(omicron(1,i))
16246         sint1=sqrt(1-cost1*cost1)
16247         cost2=dcos(omicron(2,i))
16248         sint2=sqrt(1-cost2*cost2)
16249        do j=1,3
16250 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16251           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16252           cost1*dc_norm(j,i-2))/ &
16253           vbld(i-1)
16254           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16255           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16256           +cost1*(dc_norm(j,i-1+nres)))/ &
16257           vbld(i-1+nres)
16258           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16259 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16260 !C Looks messy but better than if in loop
16261           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16262           +cost2*dc_norm(j,i-1))/ &
16263           vbld(i)
16264           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16265           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16266            +cost2*(-dc_norm(j,i-1+nres)))/ &
16267           vbld(i-1+nres)
16268 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
16269           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16270         enddo
16271        endif
16272       enddo
16273 !elwrite(iout,*) "after vbld write"
16274 ! Derivatives of phi:
16275 ! If phi is 0 or 180 degrees, then the formulas
16276 ! have to be derived by power series expansion of the
16277 ! conventional formulas around 0 and 180.
16278 #ifdef PARINTDER
16279       do i=iphi1_start,iphi1_end
16280 #else
16281       do i=4,nres
16282 #endif
16283 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
16284 ! the conventional case
16285         sint=dsin(theta(i))
16286         sint1=dsin(theta(i-1))
16287         sing=dsin(phi(i))
16288         cost=dcos(theta(i))
16289         cost1=dcos(theta(i-1))
16290         cosg=dcos(phi(i))
16291         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16292         fac0=1.0d0/(sint1*sint)
16293         fac1=cost*fac0
16294         fac2=cost1*fac0
16295         fac3=cosg*cost1/(sint1*sint1)
16296         fac4=cosg*cost/(sint*sint)
16297 !    Obtaining the gamma derivatives from sine derivative
16298        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16299            phi(i).gt.pi34.and.phi(i).le.pi.or. &
16300            phi(i).ge.-pi.and.phi(i).le.-pi34) then
16301          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16302          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16303          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16304          do j=1,3
16305             ctgt=cost/sint
16306             ctgt1=cost1/sint1
16307             cosg_inv=1.0d0/cosg
16308             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
16309             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16310               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16311             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16312             dsinphi(j,2,i)= &
16313               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16314               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16315             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16316             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16317               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16318 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16319             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16320             endif
16321 ! Bug fixed 3/24/05 (AL)
16322          enddo
16323 !   Obtaining the gamma derivatives from cosine derivative
16324         else
16325            do j=1,3
16326            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
16327            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16328            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16329            dc_norm(j,i-3))/vbld(i-2)
16330            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16331            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16332            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16333            dcostheta(j,1,i)
16334            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16335            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16336            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16337            dc_norm(j,i-1))/vbld(i)
16338            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16339            endif
16340          enddo
16341         endif
16342       enddo
16343 !alculate derivative of Tauangle
16344 #ifdef PARINTDER
16345       do i=itau_start,itau_end
16346 #else
16347       do i=3,nres
16348 !elwrite(iout,*) " vecpr",i,nres
16349 #endif
16350        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
16351 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
16352 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
16353 !c dtauangle(j,intertyp,dervityp,residue number)
16354 !c INTERTYP=1 SC...Ca...Ca..Ca
16355 ! the conventional case
16356         sint=dsin(theta(i))
16357         sint1=dsin(omicron(2,i-1))
16358         sing=dsin(tauangle(1,i))
16359         cost=dcos(theta(i))
16360         cost1=dcos(omicron(2,i-1))
16361         cosg=dcos(tauangle(1,i))
16362 !elwrite(iout,*) " vecpr5",i,nres
16363         do j=1,3
16364 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16365 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16366         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16367 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16368         enddo
16369         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16370         fac0=1.0d0/(sint1*sint)
16371         fac1=cost*fac0
16372         fac2=cost1*fac0
16373         fac3=cosg*cost1/(sint1*sint1)
16374         fac4=cosg*cost/(sint*sint)
16375 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16376 !    Obtaining the gamma derivatives from sine derivative
16377        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16378            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16379            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16380          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16381          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16382          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16383         do j=1,3
16384             ctgt=cost/sint
16385             ctgt1=cost1/sint1
16386             cosg_inv=1.0d0/cosg
16387             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16388        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16389        *vbld_inv(i-2+nres)
16390             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16391             dsintau(j,1,2,i)= &
16392               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16393               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16394 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16395             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16396 ! Bug fixed 3/24/05 (AL)
16397             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16398               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16399 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16400             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16401          enddo
16402 !   Obtaining the gamma derivatives from cosine derivative
16403         else
16404            do j=1,3
16405            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16406            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16407            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16408            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16409            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16410            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16411            dcostheta(j,1,i)
16412            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16413            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16414            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16415            dc_norm(j,i-1))/vbld(i)
16416            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16417 !         write (iout,*) "else",i
16418          enddo
16419         endif
16420 !        do k=1,3
16421 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16422 !        enddo
16423       enddo
16424 !C Second case Ca...Ca...Ca...SC
16425 #ifdef PARINTDER
16426       do i=itau_start,itau_end
16427 #else
16428       do i=4,nres
16429 #endif
16430        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
16431           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
16432 ! the conventional case
16433         sint=dsin(omicron(1,i))
16434         sint1=dsin(theta(i-1))
16435         sing=dsin(tauangle(2,i))
16436         cost=dcos(omicron(1,i))
16437         cost1=dcos(theta(i-1))
16438         cosg=dcos(tauangle(2,i))
16439 !        do j=1,3
16440 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16441 !        enddo
16442         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16443         fac0=1.0d0/(sint1*sint)
16444         fac1=cost*fac0
16445         fac2=cost1*fac0
16446         fac3=cosg*cost1/(sint1*sint1)
16447         fac4=cosg*cost/(sint*sint)
16448 !    Obtaining the gamma derivatives from sine derivative
16449        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16450            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16451            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16452          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16453          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16454          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16455         do j=1,3
16456             ctgt=cost/sint
16457             ctgt1=cost1/sint1
16458             cosg_inv=1.0d0/cosg
16459             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16460               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16461 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16462 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16463             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16464             dsintau(j,2,2,i)= &
16465               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16466               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16467 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16468 !     & sing*ctgt*domicron(j,1,2,i),
16469 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16470             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16471 ! Bug fixed 3/24/05 (AL)
16472             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16473              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16474 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16475             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16476          enddo
16477 !   Obtaining the gamma derivatives from cosine derivative
16478         else
16479            do j=1,3
16480            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16481            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16482            dc_norm(j,i-3))/vbld(i-2)
16483            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16484            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16485            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16486            dcosomicron(j,1,1,i)
16487            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16488            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16489            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16490            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16491            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16492 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16493          enddo
16494         endif
16495       enddo
16496
16497 !CC third case SC...Ca...Ca...SC
16498 #ifdef PARINTDER
16499
16500       do i=itau_start,itau_end
16501 #else
16502       do i=3,nres
16503 #endif
16504 ! the conventional case
16505       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
16506       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
16507         sint=dsin(omicron(1,i))
16508         sint1=dsin(omicron(2,i-1))
16509         sing=dsin(tauangle(3,i))
16510         cost=dcos(omicron(1,i))
16511         cost1=dcos(omicron(2,i-1))
16512         cosg=dcos(tauangle(3,i))
16513         do j=1,3
16514         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16515 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16516         enddo
16517         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16518         fac0=1.0d0/(sint1*sint)
16519         fac1=cost*fac0
16520         fac2=cost1*fac0
16521         fac3=cosg*cost1/(sint1*sint1)
16522         fac4=cosg*cost/(sint*sint)
16523 !    Obtaining the gamma derivatives from sine derivative
16524        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16525            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16526            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16527          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16528          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16529          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16530         do j=1,3
16531             ctgt=cost/sint
16532             ctgt1=cost1/sint1
16533             cosg_inv=1.0d0/cosg
16534             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16535               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16536               *vbld_inv(i-2+nres)
16537             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16538             dsintau(j,3,2,i)= &
16539               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16540               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16541             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16542 ! Bug fixed 3/24/05 (AL)
16543             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16544               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16545               *vbld_inv(i-1+nres)
16546 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16547             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16548          enddo
16549 !   Obtaining the gamma derivatives from cosine derivative
16550         else
16551            do j=1,3
16552            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16553            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16554            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16555            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16556            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16557            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16558            dcosomicron(j,1,1,i)
16559            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16560            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16561            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16562            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16563            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16564 !          write(iout,*) "else",i
16565          enddo
16566         endif
16567       enddo
16568
16569 #ifdef CRYST_SC
16570 !   Derivatives of side-chain angles alpha and omega
16571 #if defined(MPI) && defined(PARINTDER)
16572         do i=ibond_start,ibond_end
16573 #else
16574         do i=2,nres-1
16575 #endif
16576           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
16577              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16578              fac6=fac5/vbld(i)
16579              fac7=fac5*fac5
16580              fac8=fac5/vbld(i+1)
16581              fac9=fac5/vbld(i+nres)
16582              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16583              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16584              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16585              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16586              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16587              sina=sqrt(1-cosa*cosa)
16588              sino=dsin(omeg(i))
16589 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16590              do j=1,3
16591                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16592                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16593                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16594                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16595                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16596                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16597                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16598                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16599                 vbld(i+nres))
16600                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16601             enddo
16602 ! obtaining the derivatives of omega from sines
16603             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16604                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16605                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16606                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16607                dsin(theta(i+1)))
16608                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16609                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16610                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16611                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16612                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16613                coso_inv=1.0d0/dcos(omeg(i))
16614                do j=1,3
16615                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16616                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16617                  (sino*dc_norm(j,i-1))/vbld(i)
16618                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16619                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16620                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16621                  -sino*dc_norm(j,i)/vbld(i+1)
16622                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16623                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16624                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16625                  vbld(i+nres)
16626                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16627               enddo
16628            else
16629 !   obtaining the derivatives of omega from cosines
16630              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16631              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16632              fac12=fac10*sina
16633              fac13=fac12*fac12
16634              fac14=sina*sina
16635              do j=1,3
16636                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16637                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16638                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16639                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16640                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
16641                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
16642                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
16643                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
16644                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
16645                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
16646                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
16647                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
16648                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
16649                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
16650                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
16651             enddo
16652           endif
16653          else
16654            do j=1,3
16655              do k=1,3
16656                dalpha(k,j,i)=0.0d0
16657                domega(k,j,i)=0.0d0
16658              enddo
16659            enddo
16660          endif
16661        enddo
16662 #endif
16663 #if defined(MPI) && defined(PARINTDER)
16664       if (nfgtasks.gt.1) then
16665 #ifdef DEBUG
16666 !d      write (iout,*) "Gather dtheta"
16667 !d      call flush(iout)
16668       write (iout,*) "dtheta before gather"
16669       do i=1,nres
16670         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
16671       enddo
16672 #endif
16673       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
16674         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
16675         king,FG_COMM,IERROR)
16676 #ifdef DEBUG
16677 !d      write (iout,*) "Gather dphi"
16678 !d      call flush(iout)
16679       write (iout,*) "dphi before gather"
16680       do i=1,nres
16681         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
16682       enddo
16683 #endif
16684       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
16685         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
16686         king,FG_COMM,IERROR)
16687 !d      write (iout,*) "Gather dalpha"
16688 !d      call flush(iout)
16689 #ifdef CRYST_SC
16690       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
16691         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16692         king,FG_COMM,IERROR)
16693 !d      write (iout,*) "Gather domega"
16694 !d      call flush(iout)
16695       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
16696         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16697         king,FG_COMM,IERROR)
16698 #endif
16699       endif
16700 #endif
16701 #ifdef DEBUG
16702       write (iout,*) "dtheta after gather"
16703       do i=1,nres
16704         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
16705       enddo
16706       write (iout,*) "dphi after gather"
16707       do i=1,nres
16708         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
16709       enddo
16710       write (iout,*) "dalpha after gather"
16711       do i=1,nres
16712         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
16713       enddo
16714       write (iout,*) "domega after gather"
16715       do i=1,nres
16716         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
16717       enddo
16718 #endif
16719       return
16720       end subroutine intcartderiv
16721 !-----------------------------------------------------------------------------
16722       subroutine checkintcartgrad
16723 !      implicit real*8 (a-h,o-z)
16724 !      include 'DIMENSIONS'
16725 #ifdef MPI
16726       include 'mpif.h'
16727 #endif
16728 !      include 'COMMON.CHAIN'
16729 !      include 'COMMON.VAR'
16730 !      include 'COMMON.GEO'
16731 !      include 'COMMON.INTERACT'
16732 !      include 'COMMON.DERIV'
16733 !      include 'COMMON.IOUNITS'
16734 !      include 'COMMON.SETUP'
16735       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
16736       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
16737       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
16738       real(kind=8),dimension(3) :: dc_norm_s
16739       real(kind=8) :: aincr=1.0d-5
16740       integer :: i,j
16741       real(kind=8) :: dcji
16742       do i=1,nres
16743         phi_s(i)=phi(i)
16744         theta_s(i)=theta(i)
16745         alph_s(i)=alph(i)
16746         omeg_s(i)=omeg(i)
16747       enddo
16748 ! Check theta gradient
16749       write (iout,*) &
16750        "Analytical (upper) and numerical (lower) gradient of theta"
16751       write (iout,*)
16752       do i=3,nres
16753         do j=1,3
16754           dcji=dc(j,i-2)
16755           dc(j,i-2)=dcji+aincr
16756           call chainbuild_cart
16757           call int_from_cart1(.false.)
16758           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
16759           dc(j,i-2)=dcji
16760           dcji=dc(j,i-1)
16761           dc(j,i-1)=dc(j,i-1)+aincr
16762           call chainbuild_cart
16763           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
16764           dc(j,i-1)=dcji
16765         enddo
16766 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
16767 !el          (dtheta(j,2,i),j=1,3)
16768 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
16769 !el          (dthetanum(j,2,i),j=1,3)
16770 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
16771 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
16772 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
16773 !el        write (iout,*)
16774       enddo
16775 ! Check gamma gradient
16776       write (iout,*) &
16777        "Analytical (upper) and numerical (lower) gradient of gamma"
16778       do i=4,nres
16779         do j=1,3
16780           dcji=dc(j,i-3)
16781           dc(j,i-3)=dcji+aincr
16782           call chainbuild_cart
16783           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
16784           dc(j,i-3)=dcji
16785           dcji=dc(j,i-2)
16786           dc(j,i-2)=dcji+aincr
16787           call chainbuild_cart
16788           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
16789           dc(j,i-2)=dcji
16790           dcji=dc(j,i-1)
16791           dc(j,i-1)=dc(j,i-1)+aincr
16792           call chainbuild_cart
16793           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
16794           dc(j,i-1)=dcji
16795         enddo
16796 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
16797 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
16798 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
16799 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
16800 !el        write (iout,'(5x,3(3f10.5,5x))') &
16801 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
16802 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
16803 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
16804 !el        write (iout,*)
16805       enddo
16806 ! Check alpha gradient
16807       write (iout,*) &
16808        "Analytical (upper) and numerical (lower) gradient of alpha"
16809       do i=2,nres-1
16810        if(itype(i).ne.10) then
16811             do j=1,3
16812               dcji=dc(j,i-1)
16813               dc(j,i-1)=dcji+aincr
16814               call chainbuild_cart
16815               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
16816               /aincr
16817               dc(j,i-1)=dcji
16818               dcji=dc(j,i)
16819               dc(j,i)=dcji+aincr
16820               call chainbuild_cart
16821               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
16822               /aincr
16823               dc(j,i)=dcji
16824               dcji=dc(j,i+nres)
16825               dc(j,i+nres)=dc(j,i+nres)+aincr
16826               call chainbuild_cart
16827               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
16828               /aincr
16829              dc(j,i+nres)=dcji
16830             enddo
16831           endif
16832 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
16833 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
16834 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
16835 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
16836 !el        write (iout,'(5x,3(3f10.5,5x))') &
16837 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
16838 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
16839 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
16840 !el        write (iout,*)
16841       enddo
16842 !     Check omega gradient
16843       write (iout,*) &
16844        "Analytical (upper) and numerical (lower) gradient of omega"
16845       do i=2,nres-1
16846        if(itype(i).ne.10) then
16847             do j=1,3
16848               dcji=dc(j,i-1)
16849               dc(j,i-1)=dcji+aincr
16850               call chainbuild_cart
16851               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
16852               /aincr
16853               dc(j,i-1)=dcji
16854               dcji=dc(j,i)
16855               dc(j,i)=dcji+aincr
16856               call chainbuild_cart
16857               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
16858               /aincr
16859               dc(j,i)=dcji
16860               dcji=dc(j,i+nres)
16861               dc(j,i+nres)=dc(j,i+nres)+aincr
16862               call chainbuild_cart
16863               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
16864               /aincr
16865              dc(j,i+nres)=dcji
16866             enddo
16867           endif
16868 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
16869 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
16870 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
16871 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
16872 !el        write (iout,'(5x,3(3f10.5,5x))') &
16873 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
16874 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
16875 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
16876 !el        write (iout,*)
16877       enddo
16878       return
16879       end subroutine checkintcartgrad
16880 !-----------------------------------------------------------------------------
16881 ! q_measure.F
16882 !-----------------------------------------------------------------------------
16883       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
16884 !      implicit real*8 (a-h,o-z)
16885 !      include 'DIMENSIONS'
16886 !      include 'COMMON.IOUNITS'
16887 !      include 'COMMON.CHAIN'
16888 !      include 'COMMON.INTERACT'
16889 !      include 'COMMON.VAR'
16890       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
16891       integer :: kkk,nsep=3
16892       real(kind=8) :: qm        !dist,
16893       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
16894       logical :: lprn=.false.
16895       logical :: flag
16896 !      real(kind=8) :: sigm,x
16897
16898 !el      sigm(x)=0.25d0*x     ! local function
16899       qqmax=1.0d10
16900       do kkk=1,nperm
16901       qq = 0.0d0
16902       nl=0
16903        if(flag) then
16904         do il=seg1+nsep,seg2
16905           do jl=seg1,il-nsep
16906             nl=nl+1
16907             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
16908                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
16909                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16910             dij=dist(il,jl)
16911             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
16912             if (itype(il).ne.10 .or. itype(jl).ne.10) then
16913               nl=nl+1
16914               d0ijCM=dsqrt( &
16915                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16916                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16917                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16918               dijCM=dist(il+nres,jl+nres)
16919               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
16920             endif
16921             qq = qq+qqij+qqijCM
16922           enddo
16923         enddo
16924         qq = qq/nl
16925       else
16926       do il=seg1,seg2
16927         if((seg3-il).lt.3) then
16928              secseg=il+3
16929         else
16930              secseg=seg3
16931         endif
16932           do jl=secseg,seg4
16933             nl=nl+1
16934             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16935                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16936                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16937             dij=dist(il,jl)
16938             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
16939             if (itype(il).ne.10 .or. itype(jl).ne.10) then
16940               nl=nl+1
16941               d0ijCM=dsqrt( &
16942                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16943                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16944                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16945               dijCM=dist(il+nres,jl+nres)
16946               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
16947             endif
16948             qq = qq+qqij+qqijCM
16949           enddo
16950         enddo
16951       qq = qq/nl
16952       endif
16953       if (qqmax.le.qq) qqmax=qq
16954       enddo
16955       qwolynes=1.0d0-qqmax
16956       return
16957       end function qwolynes
16958 !-----------------------------------------------------------------------------
16959       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
16960 !      implicit real*8 (a-h,o-z)
16961 !      include 'DIMENSIONS'
16962 !      include 'COMMON.IOUNITS'
16963 !      include 'COMMON.CHAIN'
16964 !      include 'COMMON.INTERACT'
16965 !      include 'COMMON.VAR'
16966 !      include 'COMMON.MD'
16967       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
16968       integer :: nsep=3, kkk
16969 !el      real(kind=8) :: dist
16970       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
16971       logical :: lprn=.false.
16972       logical :: flag
16973       real(kind=8) :: sim,dd0,fac,ddqij
16974 !el      sigm(x)=0.25d0*x            ! local function
16975       do kkk=1,nperm
16976       do i=0,nres
16977         do j=1,3
16978           dqwol(j,i)=0.0d0
16979           dxqwol(j,i)=0.0d0
16980         enddo
16981       enddo
16982       nl=0
16983        if(flag) then
16984         do il=seg1+nsep,seg2
16985           do jl=seg1,il-nsep
16986             nl=nl+1
16987             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16988                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16989                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16990             dij=dist(il,jl)
16991             sim = 1.0d0/sigm(d0ij)
16992             sim = sim*sim
16993             dd0 = dij-d0ij
16994             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
16995             do k=1,3
16996               ddqij = (c(k,il)-c(k,jl))*fac
16997               dqwol(k,il)=dqwol(k,il)+ddqij
16998               dqwol(k,jl)=dqwol(k,jl)-ddqij
16999             enddo
17000
17001             if (itype(il).ne.10 .or. itype(jl).ne.10) then
17002               nl=nl+1
17003               d0ijCM=dsqrt( &
17004                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17005                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17006                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17007               dijCM=dist(il+nres,jl+nres)
17008               sim = 1.0d0/sigm(d0ijCM)
17009               sim = sim*sim
17010               dd0=dijCM-d0ijCM
17011               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17012               do k=1,3
17013                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17014                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17015                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17016               enddo
17017             endif
17018           enddo
17019         enddo
17020        else
17021         do il=seg1,seg2
17022         if((seg3-il).lt.3) then
17023              secseg=il+3
17024         else
17025              secseg=seg3
17026         endif
17027           do jl=secseg,seg4
17028             nl=nl+1
17029             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17030                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17031                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17032             dij=dist(il,jl)
17033             sim = 1.0d0/sigm(d0ij)
17034             sim = sim*sim
17035             dd0 = dij-d0ij
17036             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17037             do k=1,3
17038               ddqij = (c(k,il)-c(k,jl))*fac
17039               dqwol(k,il)=dqwol(k,il)+ddqij
17040               dqwol(k,jl)=dqwol(k,jl)-ddqij
17041             enddo
17042             if (itype(il).ne.10 .or. itype(jl).ne.10) then
17043               nl=nl+1
17044               d0ijCM=dsqrt( &
17045                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17046                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17047                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17048               dijCM=dist(il+nres,jl+nres)
17049               sim = 1.0d0/sigm(d0ijCM)
17050               sim=sim*sim
17051               dd0 = dijCM-d0ijCM
17052               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17053               do k=1,3
17054                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17055                dxqwol(k,il)=dxqwol(k,il)+ddqij
17056                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17057               enddo
17058             endif
17059           enddo
17060         enddo
17061       endif
17062       enddo
17063        do i=0,nres
17064          do j=1,3
17065            dqwol(j,i)=dqwol(j,i)/nl
17066            dxqwol(j,i)=dxqwol(j,i)/nl
17067          enddo
17068        enddo
17069       return
17070       end subroutine qwolynes_prim
17071 !-----------------------------------------------------------------------------
17072       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17073 !      implicit real*8 (a-h,o-z)
17074 !      include 'DIMENSIONS'
17075 !      include 'COMMON.IOUNITS'
17076 !      include 'COMMON.CHAIN'
17077 !      include 'COMMON.INTERACT'
17078 !      include 'COMMON.VAR'
17079       integer :: seg1,seg2,seg3,seg4
17080       logical :: flag
17081       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17082       real(kind=8),dimension(3,0:2*nres) :: cdummy
17083       real(kind=8) :: q1,q2
17084       real(kind=8) :: delta=1.0d-10
17085       integer :: i,j
17086
17087       do i=0,nres
17088         do j=1,3
17089           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17090           cdummy(j,i)=c(j,i)
17091           c(j,i)=c(j,i)+delta
17092           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17093           qwolan(j,i)=(q2-q1)/delta
17094           c(j,i)=cdummy(j,i)
17095         enddo
17096       enddo
17097       do i=0,nres
17098         do j=1,3
17099           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17100           cdummy(j,i+nres)=c(j,i+nres)
17101           c(j,i+nres)=c(j,i+nres)+delta
17102           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17103           qwolxan(j,i)=(q2-q1)/delta
17104           c(j,i+nres)=cdummy(j,i+nres)
17105         enddo
17106       enddo
17107 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17108 !      do i=0,nct
17109 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17110 !      enddo
17111 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17112 !      do i=0,nct
17113 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17114 !      enddo
17115       return
17116       end subroutine qwol_num
17117 !-----------------------------------------------------------------------------
17118       subroutine EconstrQ
17119 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17120 !      implicit real*8 (a-h,o-z)
17121 !      include 'DIMENSIONS'
17122 !      include 'COMMON.CONTROL'
17123 !      include 'COMMON.VAR'
17124 !      include 'COMMON.MD'
17125       use MD_data
17126 !#ifndef LANG0
17127 !      include 'COMMON.LANGEVIN'
17128 !#else
17129 !      include 'COMMON.LANGEVIN.lang0'
17130 !#endif
17131 !      include 'COMMON.CHAIN'
17132 !      include 'COMMON.DERIV'
17133 !      include 'COMMON.GEO'
17134 !      include 'COMMON.LOCAL'
17135 !      include 'COMMON.INTERACT'
17136 !      include 'COMMON.IOUNITS'
17137 !      include 'COMMON.NAMES'
17138 !      include 'COMMON.TIME1'
17139       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17140       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17141                    duconst,duxconst
17142       integer :: kstart,kend,lstart,lend,idummy
17143       real(kind=8) :: delta=1.0d-7
17144       integer :: i,j,k,ii
17145       do i=0,nres
17146          do j=1,3
17147             duconst(j,i)=0.0d0
17148             dudconst(j,i)=0.0d0
17149             duxconst(j,i)=0.0d0
17150             dudxconst(j,i)=0.0d0
17151          enddo
17152       enddo
17153       Uconst=0.0d0
17154       do i=1,nfrag
17155          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17156            idummy,idummy)
17157          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17158 ! Calculating the derivatives of Constraint energy with respect to Q
17159          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17160            qinfrag(i,iset))
17161 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17162 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17163 !         hmnum=(hm2-hm1)/delta
17164 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17165 !     &   qinfrag(i,iset))
17166 !         write(iout,*) "harmonicnum frag", hmnum
17167 ! Calculating the derivatives of Q with respect to cartesian coordinates
17168          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17169           idummy,idummy)
17170 !         write(iout,*) "dqwol "
17171 !         do ii=1,nres
17172 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17173 !         enddo
17174 !         write(iout,*) "dxqwol "
17175 !         do ii=1,nres
17176 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17177 !         enddo
17178 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17179 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17180 !     &  ,idummy,idummy)
17181 !  The gradients of Uconst in Cs
17182          do ii=0,nres
17183             do j=1,3
17184                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17185                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17186             enddo
17187          enddo
17188       enddo
17189       do i=1,npair
17190          kstart=ifrag(1,ipair(1,i,iset),iset)
17191          kend=ifrag(2,ipair(1,i,iset),iset)
17192          lstart=ifrag(1,ipair(2,i,iset),iset)
17193          lend=ifrag(2,ipair(2,i,iset),iset)
17194          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17195          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17196 !  Calculating dU/dQ
17197          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17198 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17199 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17200 !         hmnum=(hm2-hm1)/delta
17201 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17202 !     &   qinpair(i,iset))
17203 !         write(iout,*) "harmonicnum pair ", hmnum
17204 ! Calculating dQ/dXi
17205          call qwolynes_prim(kstart,kend,.false.,&
17206           lstart,lend)
17207 !         write(iout,*) "dqwol "
17208 !         do ii=1,nres
17209 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17210 !         enddo
17211 !         write(iout,*) "dxqwol "
17212 !         do ii=1,nres
17213 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17214 !        enddo
17215 ! Calculating numerical gradients
17216 !        call qwol_num(kstart,kend,.false.
17217 !     &  ,lstart,lend)
17218 ! The gradients of Uconst in Cs
17219          do ii=0,nres
17220             do j=1,3
17221                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17222                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17223             enddo
17224          enddo
17225       enddo
17226 !      write(iout,*) "Uconst inside subroutine ", Uconst
17227 ! Transforming the gradients from Cs to dCs for the backbone
17228       do i=0,nres
17229          do j=i+1,nres
17230            do k=1,3
17231              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17232            enddo
17233          enddo
17234       enddo
17235 !  Transforming the gradients from Cs to dCs for the side chains
17236       do i=1,nres
17237          do j=1,3
17238            dudxconst(j,i)=duxconst(j,i)
17239          enddo
17240       enddo
17241 !      write(iout,*) "dU/ddc backbone "
17242 !       do ii=0,nres
17243 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17244 !      enddo
17245 !      write(iout,*) "dU/ddX side chain "
17246 !      do ii=1,nres
17247 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17248 !      enddo
17249 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17250 !      call dEconstrQ_num
17251       return
17252       end subroutine EconstrQ
17253 !-----------------------------------------------------------------------------
17254       subroutine dEconstrQ_num
17255 ! Calculating numerical dUconst/ddc and dUconst/ddx
17256 !      implicit real*8 (a-h,o-z)
17257 !      include 'DIMENSIONS'
17258 !      include 'COMMON.CONTROL'
17259 !      include 'COMMON.VAR'
17260 !      include 'COMMON.MD'
17261       use MD_data
17262 !#ifndef LANG0
17263 !      include 'COMMON.LANGEVIN'
17264 !#else
17265 !      include 'COMMON.LANGEVIN.lang0'
17266 !#endif
17267 !      include 'COMMON.CHAIN'
17268 !      include 'COMMON.DERIV'
17269 !      include 'COMMON.GEO'
17270 !      include 'COMMON.LOCAL'
17271 !      include 'COMMON.INTERACT'
17272 !      include 'COMMON.IOUNITS'
17273 !      include 'COMMON.NAMES'
17274 !      include 'COMMON.TIME1'
17275       real(kind=8) :: uzap1,uzap2
17276       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17277       integer :: kstart,kend,lstart,lend,idummy
17278       real(kind=8) :: delta=1.0d-7
17279 !el local variables
17280       integer :: i,ii,j
17281 !     real(kind=8) ::
17282 !     For the backbone
17283       do i=0,nres-1
17284          do j=1,3
17285             dUcartan(j,i)=0.0d0
17286             cdummy(j,i)=dc(j,i)
17287             dc(j,i)=dc(j,i)+delta
17288             call chainbuild_cart
17289             uzap2=0.0d0
17290             do ii=1,nfrag
17291              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17292                 idummy,idummy)
17293                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17294                 qinfrag(ii,iset))
17295             enddo
17296             do ii=1,npair
17297                kstart=ifrag(1,ipair(1,ii,iset),iset)
17298                kend=ifrag(2,ipair(1,ii,iset),iset)
17299                lstart=ifrag(1,ipair(2,ii,iset),iset)
17300                lend=ifrag(2,ipair(2,ii,iset),iset)
17301                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17302                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17303                  qinpair(ii,iset))
17304             enddo
17305             dc(j,i)=cdummy(j,i)
17306             call chainbuild_cart
17307             uzap1=0.0d0
17308              do ii=1,nfrag
17309              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17310                 idummy,idummy)
17311                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17312                 qinfrag(ii,iset))
17313             enddo
17314             do ii=1,npair
17315                kstart=ifrag(1,ipair(1,ii,iset),iset)
17316                kend=ifrag(2,ipair(1,ii,iset),iset)
17317                lstart=ifrag(1,ipair(2,ii,iset),iset)
17318                lend=ifrag(2,ipair(2,ii,iset),iset)
17319                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17320                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17321                 qinpair(ii,iset))
17322             enddo
17323             ducartan(j,i)=(uzap2-uzap1)/(delta)
17324          enddo
17325       enddo
17326 ! Calculating numerical gradients for dU/ddx
17327       do i=0,nres-1
17328          duxcartan(j,i)=0.0d0
17329          do j=1,3
17330             cdummy(j,i)=dc(j,i+nres)
17331             dc(j,i+nres)=dc(j,i+nres)+delta
17332             call chainbuild_cart
17333             uzap2=0.0d0
17334             do ii=1,nfrag
17335              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17336                 idummy,idummy)
17337                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17338                 qinfrag(ii,iset))
17339             enddo
17340             do ii=1,npair
17341                kstart=ifrag(1,ipair(1,ii,iset),iset)
17342                kend=ifrag(2,ipair(1,ii,iset),iset)
17343                lstart=ifrag(1,ipair(2,ii,iset),iset)
17344                lend=ifrag(2,ipair(2,ii,iset),iset)
17345                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17346                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17347                 qinpair(ii,iset))
17348             enddo
17349             dc(j,i+nres)=cdummy(j,i)
17350             call chainbuild_cart
17351             uzap1=0.0d0
17352              do ii=1,nfrag
17353                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17354                 ifrag(2,ii,iset),.true.,idummy,idummy)
17355                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17356                 qinfrag(ii,iset))
17357             enddo
17358             do ii=1,npair
17359                kstart=ifrag(1,ipair(1,ii,iset),iset)
17360                kend=ifrag(2,ipair(1,ii,iset),iset)
17361                lstart=ifrag(1,ipair(2,ii,iset),iset)
17362                lend=ifrag(2,ipair(2,ii,iset),iset)
17363                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17364                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17365                 qinpair(ii,iset))
17366             enddo
17367             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17368          enddo
17369       enddo
17370       write(iout,*) "Numerical dUconst/ddc backbone "
17371       do ii=0,nres
17372         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17373       enddo
17374 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17375 !      do ii=1,nres
17376 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17377 !      enddo
17378       return
17379       end subroutine dEconstrQ_num
17380 !-----------------------------------------------------------------------------
17381 ! ssMD.F
17382 !-----------------------------------------------------------------------------
17383       subroutine check_energies
17384
17385 !      use random, only: ran_number
17386
17387 !      implicit none
17388 !     Includes
17389 !      include 'DIMENSIONS'
17390 !      include 'COMMON.CHAIN'
17391 !      include 'COMMON.VAR'
17392 !      include 'COMMON.IOUNITS'
17393 !      include 'COMMON.SBRIDGE'
17394 !      include 'COMMON.LOCAL'
17395 !      include 'COMMON.GEO'
17396
17397 !     External functions
17398 !EL      double precision ran_number
17399 !EL      external ran_number
17400
17401 !     Local variables
17402       integer :: i,j,k,l,lmax,p,pmax
17403       real(kind=8) :: rmin,rmax
17404       real(kind=8) :: eij
17405
17406       real(kind=8) :: d
17407       real(kind=8) :: wi,rij,tj,pj
17408 !      return
17409
17410       i=5
17411       j=14
17412
17413       d=dsc(1)
17414       rmin=2.0D0
17415       rmax=12.0D0
17416
17417       lmax=10000
17418       pmax=1
17419
17420       do k=1,3
17421         c(k,i)=0.0D0
17422         c(k,j)=0.0D0
17423         c(k,nres+i)=0.0D0
17424         c(k,nres+j)=0.0D0
17425       enddo
17426
17427       do l=1,lmax
17428
17429 !t        wi=ran_number(0.0D0,pi)
17430 !        wi=ran_number(0.0D0,pi/6.0D0)
17431 !        wi=0.0D0
17432 !t        tj=ran_number(0.0D0,pi)
17433 !t        pj=ran_number(0.0D0,pi)
17434 !        pj=ran_number(0.0D0,pi/6.0D0)
17435 !        pj=0.0D0
17436
17437         do p=1,pmax
17438 !t           rij=ran_number(rmin,rmax)
17439
17440            c(1,j)=d*sin(pj)*cos(tj)
17441            c(2,j)=d*sin(pj)*sin(tj)
17442            c(3,j)=d*cos(pj)
17443
17444            c(3,nres+i)=-rij
17445
17446            c(1,i)=d*sin(wi)
17447            c(3,i)=-rij-d*cos(wi)
17448
17449            do k=1,3
17450               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17451               dc_norm(k,nres+i)=dc(k,nres+i)/d
17452               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17453               dc_norm(k,nres+j)=dc(k,nres+j)/d
17454            enddo
17455
17456            call dyn_ssbond_ene(i,j,eij)
17457         enddo
17458       enddo
17459       call exit(1)
17460       return
17461       end subroutine check_energies
17462 !-----------------------------------------------------------------------------
17463       subroutine dyn_ssbond_ene(resi,resj,eij)
17464 !      implicit none
17465 !      Includes
17466       use calc_data
17467       use comm_sschecks
17468 !      include 'DIMENSIONS'
17469 !      include 'COMMON.SBRIDGE'
17470 !      include 'COMMON.CHAIN'
17471 !      include 'COMMON.DERIV'
17472 !      include 'COMMON.LOCAL'
17473 !      include 'COMMON.INTERACT'
17474 !      include 'COMMON.VAR'
17475 !      include 'COMMON.IOUNITS'
17476 !      include 'COMMON.CALC'
17477 #ifndef CLUST
17478 #ifndef WHAM
17479        use MD_data
17480 !      include 'COMMON.MD'
17481 !      use MD, only: totT,t_bath
17482 #endif
17483 #endif
17484 !     External functions
17485 !EL      double precision h_base
17486 !EL      external h_base
17487
17488 !     Input arguments
17489       integer :: resi,resj
17490
17491 !     Output arguments
17492       real(kind=8) :: eij
17493
17494 !     Local variables
17495       logical :: havebond
17496       integer itypi,itypj
17497       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17498       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17499       real(kind=8),dimension(3) :: dcosom1,dcosom2
17500       real(kind=8) :: ed
17501       real(kind=8) :: pom1,pom2
17502       real(kind=8) :: ljA,ljB,ljXs
17503       real(kind=8),dimension(1:3) :: d_ljB
17504       real(kind=8) :: ssA,ssB,ssC,ssXs
17505       real(kind=8) :: ssxm,ljxm,ssm,ljm
17506       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17507       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17508       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17509 !-------FIRST METHOD
17510       real(kind=8) :: xm
17511       real(kind=8),dimension(1:3) :: d_xm
17512 !-------END FIRST METHOD
17513 !-------SECOND METHOD
17514 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17515 !-------END SECOND METHOD
17516
17517 !-------TESTING CODE
17518 !el      logical :: checkstop,transgrad
17519 !el      common /sschecks/ checkstop,transgrad
17520
17521       integer :: icheck,nicheck,jcheck,njcheck
17522       real(kind=8),dimension(-1:1) :: echeck
17523       real(kind=8) :: deps,ssx0,ljx0
17524 !-------END TESTING CODE
17525
17526       eij=0.0d0
17527       i=resi
17528       j=resj
17529
17530 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17531 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17532
17533       itypi=itype(i)
17534       dxi=dc_norm(1,nres+i)
17535       dyi=dc_norm(2,nres+i)
17536       dzi=dc_norm(3,nres+i)
17537       dsci_inv=vbld_inv(i+nres)
17538
17539       itypj=itype(j)
17540       xj=c(1,nres+j)-c(1,nres+i)
17541       yj=c(2,nres+j)-c(2,nres+i)
17542       zj=c(3,nres+j)-c(3,nres+i)
17543       dxj=dc_norm(1,nres+j)
17544       dyj=dc_norm(2,nres+j)
17545       dzj=dc_norm(3,nres+j)
17546       dscj_inv=vbld_inv(j+nres)
17547
17548       chi1=chi(itypi,itypj)
17549       chi2=chi(itypj,itypi)
17550       chi12=chi1*chi2
17551       chip1=chip(itypi)
17552       chip2=chip(itypj)
17553       chip12=chip1*chip2
17554       alf1=alp(itypi)
17555       alf2=alp(itypj)
17556       alf12=0.5D0*(alf1+alf2)
17557
17558       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17559       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17560 !     The following are set in sc_angular
17561 !      erij(1)=xj*rij
17562 !      erij(2)=yj*rij
17563 !      erij(3)=zj*rij
17564 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17565 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17566 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17567       call sc_angular
17568       rij=1.0D0/rij  ! Reset this so it makes sense
17569
17570       sig0ij=sigma(itypi,itypj)
17571       sig=sig0ij*dsqrt(1.0D0/sigsq)
17572
17573       ljXs=sig-sig0ij
17574       ljA=eps1*eps2rt**2*eps3rt**2
17575       ljB=ljA*bb_aq(itypi,itypj)
17576       ljA=ljA*aa_aq(itypi,itypj)
17577       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17578
17579       ssXs=d0cm
17580       deltat1=1.0d0-om1
17581       deltat2=1.0d0+om2
17582       deltat12=om2-om1+2.0d0
17583       cosphi=om12-om1*om2
17584       ssA=akcm
17585       ssB=akct*deltat12
17586       ssC=ss_depth &
17587            +akth*(deltat1*deltat1+deltat2*deltat2) &
17588            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17589       ssxm=ssXs-0.5D0*ssB/ssA
17590
17591 !-------TESTING CODE
17592 !$$$c     Some extra output
17593 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17594 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17595 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17596 !$$$      if (ssx0.gt.0.0d0) then
17597 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17598 !$$$      else
17599 !$$$        ssx0=ssxm
17600 !$$$      endif
17601 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17602 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17603 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17604 !$$$      return
17605 !-------END TESTING CODE
17606
17607 !-------TESTING CODE
17608 !     Stop and plot energy and derivative as a function of distance
17609       if (checkstop) then
17610         ssm=ssC-0.25D0*ssB*ssB/ssA
17611         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17612         if (ssm.lt.ljm .and. &
17613              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17614           nicheck=1000
17615           njcheck=1
17616           deps=0.5d-7
17617         else
17618           checkstop=.false.
17619         endif
17620       endif
17621       if (.not.checkstop) then
17622         nicheck=0
17623         njcheck=-1
17624       endif
17625
17626       do icheck=0,nicheck
17627       do jcheck=-1,njcheck
17628       if (checkstop) rij=(ssxm-1.0d0)+ &
17629              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17630 !-------END TESTING CODE
17631
17632       if (rij.gt.ljxm) then
17633         havebond=.false.
17634         ljd=rij-ljXs
17635         fac=(1.0D0/ljd)**expon
17636         e1=fac*fac*aa_aq(itypi,itypj)
17637         e2=fac*bb_aq(itypi,itypj)
17638         eij=eps1*eps2rt*eps3rt*(e1+e2)
17639         eps2der=eij*eps3rt
17640         eps3der=eij*eps2rt
17641         eij=eij*eps2rt*eps3rt
17642
17643         sigder=-sig/sigsq
17644         e1=e1*eps1*eps2rt**2*eps3rt**2
17645         ed=-expon*(e1+eij)/ljd
17646         sigder=ed*sigder
17647         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17648         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17649         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
17650              -2.0D0*alf12*eps3der+sigder*sigsq_om12
17651       else if (rij.lt.ssxm) then
17652         havebond=.true.
17653         ssd=rij-ssXs
17654         eij=ssA*ssd*ssd+ssB*ssd+ssC
17655
17656         ed=2*akcm*ssd+akct*deltat12
17657         pom1=akct*ssd
17658         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
17659         eom1=-2*akth*deltat1-pom1-om2*pom2
17660         eom2= 2*akth*deltat2+pom1-om1*pom2
17661         eom12=pom2
17662       else
17663         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
17664
17665         d_ssxm(1)=0.5D0*akct/ssA
17666         d_ssxm(2)=-d_ssxm(1)
17667         d_ssxm(3)=0.0D0
17668
17669         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
17670         d_ljxm(2)=d_ljxm(1)*sigsq_om2
17671         d_ljxm(3)=d_ljxm(1)*sigsq_om12
17672         d_ljxm(1)=d_ljxm(1)*sigsq_om1
17673
17674 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17675         xm=0.5d0*(ssxm+ljxm)
17676         do k=1,3
17677           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
17678         enddo
17679         if (rij.lt.xm) then
17680           havebond=.true.
17681           ssm=ssC-0.25D0*ssB*ssB/ssA
17682           d_ssm(1)=0.5D0*akct*ssB/ssA
17683           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17684           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17685           d_ssm(3)=omega
17686           f1=(rij-xm)/(ssxm-xm)
17687           f2=(rij-ssxm)/(xm-ssxm)
17688           h1=h_base(f1,hd1)
17689           h2=h_base(f2,hd2)
17690           eij=ssm*h1+Ht*h2
17691           delta_inv=1.0d0/(xm-ssxm)
17692           deltasq_inv=delta_inv*delta_inv
17693           fac=ssm*hd1-Ht*hd2
17694           fac1=deltasq_inv*fac*(xm-rij)
17695           fac2=deltasq_inv*fac*(rij-ssxm)
17696           ed=delta_inv*(Ht*hd2-ssm*hd1)
17697           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
17698           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
17699           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
17700         else
17701           havebond=.false.
17702           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17703           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
17704           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
17705           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
17706                alf12/eps3rt)
17707           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
17708           f1=(rij-ljxm)/(xm-ljxm)
17709           f2=(rij-xm)/(ljxm-xm)
17710           h1=h_base(f1,hd1)
17711           h2=h_base(f2,hd2)
17712           eij=Ht*h1+ljm*h2
17713           delta_inv=1.0d0/(ljxm-xm)
17714           deltasq_inv=delta_inv*delta_inv
17715           fac=Ht*hd1-ljm*hd2
17716           fac1=deltasq_inv*fac*(ljxm-rij)
17717           fac2=deltasq_inv*fac*(rij-xm)
17718           ed=delta_inv*(ljm*hd2-Ht*hd1)
17719           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
17720           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
17721           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
17722         endif
17723 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17724
17725 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17726 !$$$        ssd=rij-ssXs
17727 !$$$        ljd=rij-ljXs
17728 !$$$        fac1=rij-ljxm
17729 !$$$        fac2=rij-ssxm
17730 !$$$
17731 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
17732 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
17733 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
17734 !$$$
17735 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
17736 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
17737 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17738 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17739 !$$$        d_ssm(3)=omega
17740 !$$$
17741 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
17742 !$$$        do k=1,3
17743 !$$$          d_ljm(k)=ljm*d_ljB(k)
17744 !$$$        enddo
17745 !$$$        ljm=ljm*ljB
17746 !$$$
17747 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
17748 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
17749 !$$$        d_ss(2)=akct*ssd
17750 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
17751 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
17752 !$$$        d_ss(3)=omega
17753 !$$$
17754 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
17755 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
17756 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
17757 !$$$        do k=1,3
17758 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
17759 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
17760 !$$$        enddo
17761 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
17762 !$$$
17763 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
17764 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
17765 !$$$        h1=h_base(f1,hd1)
17766 !$$$        h2=h_base(f2,hd2)
17767 !$$$        eij=ss*h1+ljf*h2
17768 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
17769 !$$$        deltasq_inv=delta_inv*delta_inv
17770 !$$$        fac=ljf*hd2-ss*hd1
17771 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
17772 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
17773 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
17774 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
17775 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
17776 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
17777 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
17778 !$$$
17779 !$$$        havebond=.false.
17780 !$$$        if (ed.gt.0.0d0) havebond=.true.
17781 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17782
17783       endif
17784
17785       if (havebond) then
17786 !#ifndef CLUST
17787 !#ifndef WHAM
17788 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
17789 !          write(iout,'(a15,f12.2,f8.1,2i5)')
17790 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
17791 !        endif
17792 !#endif
17793 !#endif
17794         dyn_ssbond_ij(i,j)=eij
17795       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
17796         dyn_ssbond_ij(i,j)=1.0d300
17797 !#ifndef CLUST
17798 !#ifndef WHAM
17799 !        write(iout,'(a15,f12.2,f8.1,2i5)')
17800 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
17801 !#endif
17802 !#endif
17803       endif
17804
17805 !-------TESTING CODE
17806 !el      if (checkstop) then
17807         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
17808              "CHECKSTOP",rij,eij,ed
17809         echeck(jcheck)=eij
17810 !el      endif
17811       enddo
17812       if (checkstop) then
17813         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
17814       endif
17815       enddo
17816       if (checkstop) then
17817         transgrad=.true.
17818         checkstop=.false.
17819       endif
17820 !-------END TESTING CODE
17821
17822       do k=1,3
17823         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
17824         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
17825       enddo
17826       do k=1,3
17827         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
17828       enddo
17829       do k=1,3
17830         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
17831              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
17832              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
17833         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
17834              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
17835              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
17836       enddo
17837 !grad      do k=i,j-1
17838 !grad        do l=1,3
17839 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
17840 !grad        enddo
17841 !grad      enddo
17842
17843       do l=1,3
17844         gvdwc(l,i)=gvdwc(l,i)-gg(l)
17845         gvdwc(l,j)=gvdwc(l,j)+gg(l)
17846       enddo
17847
17848       return
17849       end subroutine dyn_ssbond_ene
17850 !--------------------------------------------------------------------------
17851          subroutine triple_ssbond_ene(resi,resj,resk,eij)
17852 !      implicit none
17853 !      Includes
17854       use calc_data
17855       use comm_sschecks
17856 !      include 'DIMENSIONS'
17857 !      include 'COMMON.SBRIDGE'
17858 !      include 'COMMON.CHAIN'
17859 !      include 'COMMON.DERIV'
17860 !      include 'COMMON.LOCAL'
17861 !      include 'COMMON.INTERACT'
17862 !      include 'COMMON.VAR'
17863 !      include 'COMMON.IOUNITS'
17864 !      include 'COMMON.CALC'
17865 #ifndef CLUST
17866 #ifndef WHAM
17867        use MD_data
17868 !      include 'COMMON.MD'
17869 !      use MD, only: totT,t_bath
17870 #endif
17871 #endif
17872       double precision h_base
17873       external h_base
17874
17875 !c     Input arguments
17876       integer resi,resj,resk,m,itypi,itypj,itypk
17877
17878 !c     Output arguments
17879       double precision eij,eij1,eij2,eij3
17880
17881 !c     Local variables
17882       logical havebond
17883 !c      integer itypi,itypj,k,l
17884       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
17885       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
17886       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
17887       double precision sig0ij,ljd,sig,fac,e1,e2
17888       double precision dcosom1(3),dcosom2(3),ed
17889       double precision pom1,pom2
17890       double precision ljA,ljB,ljXs
17891       double precision d_ljB(1:3)
17892       double precision ssA,ssB,ssC,ssXs
17893       double precision ssxm,ljxm,ssm,ljm
17894       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
17895       eij=0.0
17896       if (dtriss.eq.0) return
17897       i=resi
17898       j=resj
17899       k=resk
17900 !C      write(iout,*) resi,resj,resk
17901       itypi=itype(i)
17902       dxi=dc_norm(1,nres+i)
17903       dyi=dc_norm(2,nres+i)
17904       dzi=dc_norm(3,nres+i)
17905       dsci_inv=vbld_inv(i+nres)
17906       xi=c(1,nres+i)
17907       yi=c(2,nres+i)
17908       zi=c(3,nres+i)
17909       itypj=itype(j)
17910       xj=c(1,nres+j)
17911       yj=c(2,nres+j)
17912       zj=c(3,nres+j)
17913
17914       dxj=dc_norm(1,nres+j)
17915       dyj=dc_norm(2,nres+j)
17916       dzj=dc_norm(3,nres+j)
17917       dscj_inv=vbld_inv(j+nres)
17918       itypk=itype(k)
17919       xk=c(1,nres+k)
17920       yk=c(2,nres+k)
17921       zk=c(3,nres+k)
17922
17923       dxk=dc_norm(1,nres+k)
17924       dyk=dc_norm(2,nres+k)
17925       dzk=dc_norm(3,nres+k)
17926       dscj_inv=vbld_inv(k+nres)
17927       xij=xj-xi
17928       xik=xk-xi
17929       xjk=xk-xj
17930       yij=yj-yi
17931       yik=yk-yi
17932       yjk=yk-yj
17933       zij=zj-zi
17934       zik=zk-zi
17935       zjk=zk-zj
17936       rrij=(xij*xij+yij*yij+zij*zij)
17937       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17938       rrik=(xik*xik+yik*yik+zik*zik)
17939       rik=dsqrt(rrik)
17940       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
17941       rjk=dsqrt(rrjk)
17942 !C there are three combination of distances for each trisulfide bonds
17943 !C The first case the ith atom is the center
17944 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
17945 !C distance y is second distance the a,b,c,d are parameters derived for
17946 !C this problem d parameter was set as a penalty currenlty set to 1.
17947       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
17948       eij1=0.0d0
17949       else
17950       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
17951       endif
17952 !C second case jth atom is center
17953       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
17954       eij2=0.0d0
17955       else
17956       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
17957       endif
17958 !C the third case kth atom is the center
17959       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
17960       eij3=0.0d0
17961       else
17962       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
17963       endif
17964 !C      eij2=0.0
17965 !C      eij3=0.0
17966 !C      eij1=0.0
17967       eij=eij1+eij2+eij3
17968 !C      write(iout,*)i,j,k,eij
17969 !C The energy penalty calculated now time for the gradient part
17970 !C derivative over rij
17971       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
17972       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
17973             gg(1)=xij*fac/rij
17974             gg(2)=yij*fac/rij
17975             gg(3)=zij*fac/rij
17976       do m=1,3
17977         gvdwx(m,i)=gvdwx(m,i)-gg(m)
17978         gvdwx(m,j)=gvdwx(m,j)+gg(m)
17979       enddo
17980
17981       do l=1,3
17982         gvdwc(l,i)=gvdwc(l,i)-gg(l)
17983         gvdwc(l,j)=gvdwc(l,j)+gg(l)
17984       enddo
17985 !C now derivative over rik
17986       fac=-eij1**2/dtriss* &
17987       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
17988       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
17989             gg(1)=xik*fac/rik
17990             gg(2)=yik*fac/rik
17991             gg(3)=zik*fac/rik
17992       do m=1,3
17993         gvdwx(m,i)=gvdwx(m,i)-gg(m)
17994         gvdwx(m,k)=gvdwx(m,k)+gg(m)
17995       enddo
17996       do l=1,3
17997         gvdwc(l,i)=gvdwc(l,i)-gg(l)
17998         gvdwc(l,k)=gvdwc(l,k)+gg(l)
17999       enddo
18000 !C now derivative over rjk
18001       fac=-eij2**2/dtriss* &
18002       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18003       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18004             gg(1)=xjk*fac/rjk
18005             gg(2)=yjk*fac/rjk
18006             gg(3)=zjk*fac/rjk
18007       do m=1,3
18008         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18009         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18010       enddo
18011       do l=1,3
18012         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18013         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18014       enddo
18015       return
18016       end subroutine triple_ssbond_ene
18017
18018
18019
18020 !-----------------------------------------------------------------------------
18021       real(kind=8) function h_base(x,deriv)
18022 !     A smooth function going 0->1 in range [0,1]
18023 !     It should NOT be called outside range [0,1], it will not work there.
18024       implicit none
18025
18026 !     Input arguments
18027       real(kind=8) :: x
18028
18029 !     Output arguments
18030       real(kind=8) :: deriv
18031
18032 !     Local variables
18033       real(kind=8) :: xsq
18034
18035
18036 !     Two parabolas put together.  First derivative zero at extrema
18037 !$$$      if (x.lt.0.5D0) then
18038 !$$$        h_base=2.0D0*x*x
18039 !$$$        deriv=4.0D0*x
18040 !$$$      else
18041 !$$$        deriv=1.0D0-x
18042 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18043 !$$$        deriv=4.0D0*deriv
18044 !$$$      endif
18045
18046 !     Third degree polynomial.  First derivative zero at extrema
18047       h_base=x*x*(3.0d0-2.0d0*x)
18048       deriv=6.0d0*x*(1.0d0-x)
18049
18050 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18051 !$$$      xsq=x*x
18052 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18053 !$$$      deriv=x-1.0d0
18054 !$$$      deriv=deriv*deriv
18055 !$$$      deriv=30.0d0*xsq*deriv
18056
18057       return
18058       end function h_base
18059 !-----------------------------------------------------------------------------
18060       subroutine dyn_set_nss
18061 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18062 !      implicit none
18063       use MD_data, only: totT,t_bath
18064 !     Includes
18065 !      include 'DIMENSIONS'
18066 #ifdef MPI
18067       include "mpif.h"
18068 #endif
18069 !      include 'COMMON.SBRIDGE'
18070 !      include 'COMMON.CHAIN'
18071 !      include 'COMMON.IOUNITS'
18072 !      include 'COMMON.SETUP'
18073 !      include 'COMMON.MD'
18074 !     Local variables
18075       real(kind=8) :: emin
18076       integer :: i,j,imin,ierr
18077       integer :: diff,allnss,newnss
18078       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18079                 newihpb,newjhpb
18080       logical :: found
18081       integer,dimension(0:nfgtasks) :: i_newnss
18082       integer,dimension(0:nfgtasks) :: displ
18083       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18084       integer :: g_newnss
18085
18086       allnss=0
18087       do i=1,nres-1
18088         do j=i+1,nres
18089           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18090             allnss=allnss+1
18091             allflag(allnss)=0
18092             allihpb(allnss)=i
18093             alljhpb(allnss)=j
18094           endif
18095         enddo
18096       enddo
18097
18098 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18099
18100  1    emin=1.0d300
18101       do i=1,allnss
18102         if (allflag(i).eq.0 .and. &
18103              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18104           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18105           imin=i
18106         endif
18107       enddo
18108       if (emin.lt.1.0d300) then
18109         allflag(imin)=1
18110         do i=1,allnss
18111           if (allflag(i).eq.0 .and. &
18112                (allihpb(i).eq.allihpb(imin) .or. &
18113                alljhpb(i).eq.allihpb(imin) .or. &
18114                allihpb(i).eq.alljhpb(imin) .or. &
18115                alljhpb(i).eq.alljhpb(imin))) then
18116             allflag(i)=-1
18117           endif
18118         enddo
18119         goto 1
18120       endif
18121
18122 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18123
18124       newnss=0
18125       do i=1,allnss
18126         if (allflag(i).eq.1) then
18127           newnss=newnss+1
18128           newihpb(newnss)=allihpb(i)
18129           newjhpb(newnss)=alljhpb(i)
18130         endif
18131       enddo
18132
18133 #ifdef MPI
18134       if (nfgtasks.gt.1)then
18135
18136         call MPI_Reduce(newnss,g_newnss,1,&
18137           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18138         call MPI_Gather(newnss,1,MPI_INTEGER,&
18139                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18140         displ(0)=0
18141         do i=1,nfgtasks-1,1
18142           displ(i)=i_newnss(i-1)+displ(i-1)
18143         enddo
18144         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18145                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18146                          king,FG_COMM,IERR)
18147         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18148                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18149                          king,FG_COMM,IERR)
18150         if(fg_rank.eq.0) then
18151 !         print *,'g_newnss',g_newnss
18152 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18153 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18154          newnss=g_newnss
18155          do i=1,newnss
18156           newihpb(i)=g_newihpb(i)
18157           newjhpb(i)=g_newjhpb(i)
18158          enddo
18159         endif
18160       endif
18161 #endif
18162
18163       diff=newnss-nss
18164
18165 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18166 !       print *,newnss,nss,maxdim
18167       do i=1,nss
18168         found=.false.
18169 !        print *,newnss
18170         do j=1,newnss
18171 !!          print *,j
18172           if (idssb(i).eq.newihpb(j) .and. &
18173                jdssb(i).eq.newjhpb(j)) found=.true.
18174         enddo
18175 #ifndef CLUST
18176 #ifndef WHAM
18177 !        write(iout,*) "found",found,i,j
18178         if (.not.found.and.fg_rank.eq.0) &
18179             write(iout,'(a15,f12.2,f8.1,2i5)') &
18180              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18181 #endif
18182 #endif
18183       enddo
18184
18185       do i=1,newnss
18186         found=.false.
18187         do j=1,nss
18188 !          print *,i,j
18189           if (newihpb(i).eq.idssb(j) .and. &
18190                newjhpb(i).eq.jdssb(j)) found=.true.
18191         enddo
18192 #ifndef CLUST
18193 #ifndef WHAM
18194 !        write(iout,*) "found",found,i,j
18195         if (.not.found.and.fg_rank.eq.0) &
18196             write(iout,'(a15,f12.2,f8.1,2i5)') &
18197              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18198 #endif
18199 #endif
18200       enddo
18201
18202       nss=newnss
18203       do i=1,nss
18204         idssb(i)=newihpb(i)
18205         jdssb(i)=newjhpb(i)
18206       enddo
18207
18208       return
18209       end subroutine dyn_set_nss
18210 ! Lipid transfer energy function
18211       subroutine Eliptransfer(eliptran)
18212 !C this is done by Adasko
18213 !C      print *,"wchodze"
18214 !C structure of box:
18215 !C      water
18216 !C--bordliptop-- buffore starts
18217 !C--bufliptop--- here true lipid starts
18218 !C      lipid
18219 !C--buflipbot--- lipid ends buffore starts
18220 !C--bordlipbot--buffore ends
18221       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18222       integer :: i
18223       eliptran=0.0
18224 !      print *, "I am in eliptran"
18225       do i=ilip_start,ilip_end
18226 !C       do i=1,1
18227         if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1).or.(i.eq.nres))&
18228          cycle
18229
18230         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18231         if (positi.le.0.0) positi=positi+boxzsize
18232 !C        print *,i
18233 !C first for peptide groups
18234 !c for each residue check if it is in lipid or lipid water border area
18235        if ((positi.gt.bordlipbot)  &
18236       .and.(positi.lt.bordliptop)) then
18237 !C the energy transfer exist
18238         if (positi.lt.buflipbot) then
18239 !C what fraction I am in
18240          fracinbuf=1.0d0-      &
18241              ((positi-bordlipbot)/lipbufthick)
18242 !C lipbufthick is thickenes of lipid buffore
18243          sslip=sscalelip(fracinbuf)
18244          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18245          eliptran=eliptran+sslip*pepliptran
18246          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18247          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18248 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18249
18250 !C        print *,"doing sccale for lower part"
18251 !C         print *,i,sslip,fracinbuf,ssgradlip
18252         elseif (positi.gt.bufliptop) then
18253          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18254          sslip=sscalelip(fracinbuf)
18255          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18256          eliptran=eliptran+sslip*pepliptran
18257          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18258          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18259 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18260 !C          print *, "doing sscalefor top part"
18261 !C         print *,i,sslip,fracinbuf,ssgradlip
18262         else
18263          eliptran=eliptran+pepliptran
18264 !C         print *,"I am in true lipid"
18265         endif
18266 !C       else
18267 !C       eliptran=elpitran+0.0 ! I am in water
18268        endif
18269        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18270        enddo
18271 ! here starts the side chain transfer
18272        do i=ilip_start,ilip_end
18273         if (itype(i).eq.ntyp1) cycle
18274         positi=(mod(c(3,i+nres),boxzsize))
18275         if (positi.le.0) positi=positi+boxzsize
18276 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18277 !c for each residue check if it is in lipid or lipid water border area
18278 !C       respos=mod(c(3,i+nres),boxzsize)
18279 !C       print *,positi,bordlipbot,buflipbot
18280        if ((positi.gt.bordlipbot) &
18281        .and.(positi.lt.bordliptop)) then
18282 !C the energy transfer exist
18283         if (positi.lt.buflipbot) then
18284          fracinbuf=1.0d0-   &
18285            ((positi-bordlipbot)/lipbufthick)
18286 !C lipbufthick is thickenes of lipid buffore
18287          sslip=sscalelip(fracinbuf)
18288          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18289          eliptran=eliptran+sslip*liptranene(itype(i))
18290          gliptranx(3,i)=gliptranx(3,i) &
18291       +ssgradlip*liptranene(itype(i))
18292          gliptranc(3,i-1)= gliptranc(3,i-1) &
18293       +ssgradlip*liptranene(itype(i))
18294 !C         print *,"doing sccale for lower part"
18295         elseif (positi.gt.bufliptop) then
18296          fracinbuf=1.0d0-  &
18297       ((bordliptop-positi)/lipbufthick)
18298          sslip=sscalelip(fracinbuf)
18299          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18300          eliptran=eliptran+sslip*liptranene(itype(i))
18301          gliptranx(3,i)=gliptranx(3,i)  &
18302        +ssgradlip*liptranene(itype(i))
18303          gliptranc(3,i-1)= gliptranc(3,i-1) &
18304       +ssgradlip*liptranene(itype(i))
18305 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18306         else
18307          eliptran=eliptran+liptranene(itype(i))
18308 !C         print *,"I am in true lipid"
18309         endif
18310         endif ! if in lipid or buffor
18311 !C       else
18312 !C       eliptran=elpitran+0.0 ! I am in water
18313         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18314        enddo
18315        return
18316        end  subroutine Eliptransfer
18317 !----------------------------------NANO FUNCTIONS
18318 !C-----------------------------------------------------------------------
18319 !C-----------------------------------------------------------
18320 !C This subroutine is to mimic the histone like structure but as well can be
18321 !C utilizet to nanostructures (infinit) small modification has to be used to
18322 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18323 !C gradient has to be modified at the ends
18324 !C The energy function is Kihara potential
18325 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18326 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18327 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18328 !C simple Kihara potential
18329       subroutine calctube(Etube)
18330       real(kind=8) :: vectube(3),enetube(nres*2)
18331       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18332        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18333        sc_aa_tube,sc_bb_tube
18334       integer :: i,j,iti
18335       Etube=0.0d0
18336       do i=itube_start,itube_end
18337         enetube(i)=0.0d0
18338         enetube(i+nres)=0.0d0
18339       enddo
18340 !C first we calculate the distance from tube center
18341 !C for UNRES
18342        do i=itube_start,itube_end
18343 !C lets ommit dummy atoms for now
18344        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
18345 !C now calculate distance from center of tube and direction vectors
18346       xmin=boxxsize
18347       ymin=boxysize
18348 ! Find minimum distance in periodic box
18349         do j=-1,1
18350          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18351          vectube(1)=vectube(1)+boxxsize*j
18352          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18353          vectube(2)=vectube(2)+boxysize*j
18354          xminact=abs(vectube(1)-tubecenter(1))
18355          yminact=abs(vectube(2)-tubecenter(2))
18356            if (xmin.gt.xminact) then
18357             xmin=xminact
18358             xtemp=vectube(1)
18359            endif
18360            if (ymin.gt.yminact) then
18361              ymin=yminact
18362              ytemp=vectube(2)
18363             endif
18364          enddo
18365       vectube(1)=xtemp
18366       vectube(2)=ytemp
18367       vectube(1)=vectube(1)-tubecenter(1)
18368       vectube(2)=vectube(2)-tubecenter(2)
18369
18370 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18371 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18372
18373 !C as the tube is infinity we do not calculate the Z-vector use of Z
18374 !C as chosen axis
18375       vectube(3)=0.0d0
18376 !C now calculte the distance
18377        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18378 !C now normalize vector
18379       vectube(1)=vectube(1)/tub_r
18380       vectube(2)=vectube(2)/tub_r
18381 !C calculte rdiffrence between r and r0
18382       rdiff=tub_r-tubeR0
18383 !C and its 6 power
18384       rdiff6=rdiff**6.0d0
18385 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18386        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18387 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18388 !C       print *,rdiff,rdiff6,pep_aa_tube
18389 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18390 !C now we calculate gradient
18391        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18392             6.0d0*pep_bb_tube)/rdiff6/rdiff
18393 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18394 !C     &rdiff,fac
18395 !C now direction of gg_tube vector
18396         do j=1,3
18397         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18398         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18399         enddo
18400         enddo
18401 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18402 !C        print *,gg_tube(1,0),"TU"
18403
18404
18405        do i=itube_start,itube_end
18406 !C Lets not jump over memory as we use many times iti
18407          iti=itype(i)
18408 !C lets ommit dummy atoms for now
18409          if ((iti.eq.ntyp1)  &
18410 !C in UNRES uncomment the line below as GLY has no side-chain...
18411 !C      .or.(iti.eq.10)
18412         ) cycle
18413       xmin=boxxsize
18414       ymin=boxysize
18415         do j=-1,1
18416          vectube(1)=mod((c(1,i+nres)),boxxsize)
18417          vectube(1)=vectube(1)+boxxsize*j
18418          vectube(2)=mod((c(2,i+nres)),boxysize)
18419          vectube(2)=vectube(2)+boxysize*j
18420
18421          xminact=abs(vectube(1)-tubecenter(1))
18422          yminact=abs(vectube(2)-tubecenter(2))
18423            if (xmin.gt.xminact) then
18424             xmin=xminact
18425             xtemp=vectube(1)
18426            endif
18427            if (ymin.gt.yminact) then
18428              ymin=yminact
18429              ytemp=vectube(2)
18430             endif
18431          enddo
18432       vectube(1)=xtemp
18433       vectube(2)=ytemp
18434 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18435 !C     &     tubecenter(2)
18436       vectube(1)=vectube(1)-tubecenter(1)
18437       vectube(2)=vectube(2)-tubecenter(2)
18438
18439 !C as the tube is infinity we do not calculate the Z-vector use of Z
18440 !C as chosen axis
18441       vectube(3)=0.0d0
18442 !C now calculte the distance
18443        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18444 !C now normalize vector
18445       vectube(1)=vectube(1)/tub_r
18446       vectube(2)=vectube(2)/tub_r
18447
18448 !C calculte rdiffrence between r and r0
18449       rdiff=tub_r-tubeR0
18450 !C and its 6 power
18451       rdiff6=rdiff**6.0d0
18452 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18453        sc_aa_tube=sc_aa_tube_par(iti)
18454        sc_bb_tube=sc_bb_tube_par(iti)
18455        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18456        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18457              6.0d0*sc_bb_tube/rdiff6/rdiff
18458 !C now direction of gg_tube vector
18459          do j=1,3
18460           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18461           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18462          enddo
18463         enddo
18464         do i=itube_start,itube_end
18465           Etube=Etube+enetube(i)+enetube(i+nres)
18466         enddo
18467 !C        print *,"ETUBE", etube
18468         return
18469         end subroutine calctube
18470 !C TO DO 1) add to total energy
18471 !C       2) add to gradient summation
18472 !C       3) add reading parameters (AND of course oppening of PARAM file)
18473 !C       4) add reading the center of tube
18474 !C       5) add COMMONs
18475 !C       6) add to zerograd
18476 !C       7) allocate matrices
18477
18478
18479 !C-----------------------------------------------------------------------
18480 !C-----------------------------------------------------------
18481 !C This subroutine is to mimic the histone like structure but as well can be
18482 !C utilizet to nanostructures (infinit) small modification has to be used to
18483 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18484 !C gradient has to be modified at the ends
18485 !C The energy function is Kihara potential
18486 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18487 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18488 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18489 !C simple Kihara potential
18490       subroutine calctube2(Etube)
18491       real(kind=8) :: vectube(3),enetube(nres*2)
18492       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18493        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18494        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18495       integer:: i,j,iti
18496       Etube=0.0d0
18497       do i=itube_start,itube_end
18498         enetube(i)=0.0d0
18499         enetube(i+nres)=0.0d0
18500       enddo
18501 !C first we calculate the distance from tube center
18502 !C first sugare-phosphate group for NARES this would be peptide group
18503 !C for UNRES
18504        do i=itube_start,itube_end
18505 !C lets ommit dummy atoms for now
18506
18507        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
18508 !C now calculate distance from center of tube and direction vectors
18509 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18510 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18511 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18512 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18513       xmin=boxxsize
18514       ymin=boxysize
18515         do j=-1,1
18516          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18517          vectube(1)=vectube(1)+boxxsize*j
18518          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18519          vectube(2)=vectube(2)+boxysize*j
18520
18521          xminact=abs(vectube(1)-tubecenter(1))
18522          yminact=abs(vectube(2)-tubecenter(2))
18523            if (xmin.gt.xminact) then
18524             xmin=xminact
18525             xtemp=vectube(1)
18526            endif
18527            if (ymin.gt.yminact) then
18528              ymin=yminact
18529              ytemp=vectube(2)
18530             endif
18531          enddo
18532       vectube(1)=xtemp
18533       vectube(2)=ytemp
18534       vectube(1)=vectube(1)-tubecenter(1)
18535       vectube(2)=vectube(2)-tubecenter(2)
18536
18537 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18538 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18539
18540 !C as the tube is infinity we do not calculate the Z-vector use of Z
18541 !C as chosen axis
18542       vectube(3)=0.0d0
18543 !C now calculte the distance
18544        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18545 !C now normalize vector
18546       vectube(1)=vectube(1)/tub_r
18547       vectube(2)=vectube(2)/tub_r
18548 !C calculte rdiffrence between r and r0
18549       rdiff=tub_r-tubeR0
18550 !C and its 6 power
18551       rdiff6=rdiff**6.0d0
18552 !C THIS FRAGMENT MAKES TUBE FINITE
18553         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18554         if (positi.le.0) positi=positi+boxzsize
18555 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18556 !c for each residue check if it is in lipid or lipid water border area
18557 !C       respos=mod(c(3,i+nres),boxzsize)
18558 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18559        if ((positi.gt.bordtubebot)  &
18560         .and.(positi.lt.bordtubetop)) then
18561 !C the energy transfer exist
18562         if (positi.lt.buftubebot) then
18563          fracinbuf=1.0d0-  &
18564            ((positi-bordtubebot)/tubebufthick)
18565 !C lipbufthick is thickenes of lipid buffore
18566          sstube=sscalelip(fracinbuf)
18567          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18568 !C         print *,ssgradtube, sstube,tubetranene(itype(i))
18569          enetube(i)=enetube(i)+sstube*tubetranenepep
18570 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18571 !C     &+ssgradtube*tubetranene(itype(i))
18572 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18573 !C     &+ssgradtube*tubetranene(itype(i))
18574 !C         print *,"doing sccale for lower part"
18575         elseif (positi.gt.buftubetop) then
18576          fracinbuf=1.0d0-  &
18577         ((bordtubetop-positi)/tubebufthick)
18578          sstube=sscalelip(fracinbuf)
18579          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18580          enetube(i)=enetube(i)+sstube*tubetranenepep
18581 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18582 !C     &+ssgradtube*tubetranene(itype(i))
18583 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18584 !C     &+ssgradtube*tubetranene(itype(i))
18585 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18586         else
18587          sstube=1.0d0
18588          ssgradtube=0.0d0
18589          enetube(i)=enetube(i)+sstube*tubetranenepep
18590 !C         print *,"I am in true lipid"
18591         endif
18592         else
18593 !C          sstube=0.0d0
18594 !C          ssgradtube=0.0d0
18595         cycle
18596         endif ! if in lipid or buffor
18597
18598 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18599        enetube(i)=enetube(i)+sstube* &
18600         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18601 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18602 !C       print *,rdiff,rdiff6,pep_aa_tube
18603 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18604 !C now we calculate gradient
18605        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18606              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18607 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18608 !C     &rdiff,fac
18609
18610 !C now direction of gg_tube vector
18611        do j=1,3
18612         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18613         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18614         enddo
18615          gg_tube(3,i)=gg_tube(3,i)  &
18616        +ssgradtube*enetube(i)/sstube/2.0d0
18617          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18618        +ssgradtube*enetube(i)/sstube/2.0d0
18619
18620         enddo
18621 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18622 !C        print *,gg_tube(1,0),"TU"
18623         do i=itube_start,itube_end
18624 !C Lets not jump over memory as we use many times iti
18625          iti=itype(i)
18626 !C lets ommit dummy atoms for now
18627          if ((iti.eq.ntyp1) &
18628 !!C in UNRES uncomment the line below as GLY has no side-chain...
18629            .or.(iti.eq.10) &
18630           ) cycle
18631           vectube(1)=c(1,i+nres)
18632           vectube(1)=mod(vectube(1),boxxsize)
18633           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18634           vectube(2)=c(2,i+nres)
18635           vectube(2)=mod(vectube(2),boxysize)
18636           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18637
18638       vectube(1)=vectube(1)-tubecenter(1)
18639       vectube(2)=vectube(2)-tubecenter(2)
18640 !C THIS FRAGMENT MAKES TUBE FINITE
18641         positi=(mod(c(3,i+nres),boxzsize))
18642         if (positi.le.0) positi=positi+boxzsize
18643 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18644 !c for each residue check if it is in lipid or lipid water border area
18645 !C       respos=mod(c(3,i+nres),boxzsize)
18646 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18647
18648        if ((positi.gt.bordtubebot)  &
18649         .and.(positi.lt.bordtubetop)) then
18650 !C the energy transfer exist
18651         if (positi.lt.buftubebot) then
18652          fracinbuf=1.0d0- &
18653             ((positi-bordtubebot)/tubebufthick)
18654 !C lipbufthick is thickenes of lipid buffore
18655          sstube=sscalelip(fracinbuf)
18656          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18657 !C         print *,ssgradtube, sstube,tubetranene(itype(i))
18658          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
18659 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18660 !C     &+ssgradtube*tubetranene(itype(i))
18661 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18662 !C     &+ssgradtube*tubetranene(itype(i))
18663 !C         print *,"doing sccale for lower part"
18664         elseif (positi.gt.buftubetop) then
18665          fracinbuf=1.0d0- &
18666         ((bordtubetop-positi)/tubebufthick)
18667
18668          sstube=sscalelip(fracinbuf)
18669          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18670          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
18671 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18672 !C     &+ssgradtube*tubetranene(itype(i))
18673 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18674 !C     &+ssgradtube*tubetranene(itype(i))
18675 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18676         else
18677          sstube=1.0d0
18678          ssgradtube=0.0d0
18679          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
18680 !C         print *,"I am in true lipid"
18681         endif
18682         else
18683 !C          sstube=0.0d0
18684 !C          ssgradtube=0.0d0
18685         cycle
18686         endif ! if in lipid or buffor
18687 !CEND OF FINITE FRAGMENT
18688 !C as the tube is infinity we do not calculate the Z-vector use of Z
18689 !C as chosen axis
18690       vectube(3)=0.0d0
18691 !C now calculte the distance
18692        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18693 !C now normalize vector
18694       vectube(1)=vectube(1)/tub_r
18695       vectube(2)=vectube(2)/tub_r
18696 !C calculte rdiffrence between r and r0
18697       rdiff=tub_r-tubeR0
18698 !C and its 6 power
18699       rdiff6=rdiff**6.0d0
18700 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18701        sc_aa_tube=sc_aa_tube_par(iti)
18702        sc_bb_tube=sc_bb_tube_par(iti)
18703        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
18704                        *sstube+enetube(i+nres)
18705 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18706 !C now we calculate gradient
18707        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
18708             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
18709 !C now direction of gg_tube vector
18710          do j=1,3
18711           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18712           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18713          enddo
18714          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
18715        +ssgradtube*enetube(i+nres)/sstube
18716          gg_tube(3,i-1)= gg_tube(3,i-1) &
18717        +ssgradtube*enetube(i+nres)/sstube
18718
18719         enddo
18720         do i=itube_start,itube_end
18721           Etube=Etube+enetube(i)+enetube(i+nres)
18722         enddo
18723 !C        print *,"ETUBE", etube
18724         return
18725         end subroutine calctube2
18726 !=====================================================================================================================================
18727       subroutine calcnano(Etube)
18728       real(kind=8) :: vectube(3),enetube(nres*2), &
18729       enecavtube(nres*2)
18730       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18731        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
18732        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
18733        integer:: i,j,iti
18734
18735       Etube=0.0d0
18736 !      print *,itube_start,itube_end,"poczatek"
18737       do i=itube_start,itube_end
18738         enetube(i)=0.0d0
18739         enetube(i+nres)=0.0d0
18740       enddo
18741 !C first we calculate the distance from tube center
18742 !C first sugare-phosphate group for NARES this would be peptide group
18743 !C for UNRES
18744        do i=itube_start,itube_end
18745 !C lets ommit dummy atoms for now
18746        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
18747 !C now calculate distance from center of tube and direction vectors
18748       xmin=boxxsize
18749       ymin=boxysize
18750       zmin=boxzsize
18751
18752         do j=-1,1
18753          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18754          vectube(1)=vectube(1)+boxxsize*j
18755          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18756          vectube(2)=vectube(2)+boxysize*j
18757          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18758          vectube(3)=vectube(3)+boxzsize*j
18759
18760
18761          xminact=dabs(vectube(1)-tubecenter(1))
18762          yminact=dabs(vectube(2)-tubecenter(2))
18763          zminact=dabs(vectube(3)-tubecenter(3))
18764
18765            if (xmin.gt.xminact) then
18766             xmin=xminact
18767             xtemp=vectube(1)
18768            endif
18769            if (ymin.gt.yminact) then
18770              ymin=yminact
18771              ytemp=vectube(2)
18772             endif
18773            if (zmin.gt.zminact) then
18774              zmin=zminact
18775              ztemp=vectube(3)
18776             endif
18777          enddo
18778       vectube(1)=xtemp
18779       vectube(2)=ytemp
18780       vectube(3)=ztemp
18781
18782       vectube(1)=vectube(1)-tubecenter(1)
18783       vectube(2)=vectube(2)-tubecenter(2)
18784       vectube(3)=vectube(3)-tubecenter(3)
18785
18786 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18787 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18788 !C as the tube is infinity we do not calculate the Z-vector use of Z
18789 !C as chosen axis
18790 !C      vectube(3)=0.0d0
18791 !C now calculte the distance
18792        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18793 !C now normalize vector
18794       vectube(1)=vectube(1)/tub_r
18795       vectube(2)=vectube(2)/tub_r
18796       vectube(3)=vectube(3)/tub_r
18797 !C calculte rdiffrence between r and r0
18798       rdiff=tub_r-tubeR0
18799 !C and its 6 power
18800       rdiff6=rdiff**6.0d0
18801 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18802        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18803 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18804 !C       print *,rdiff,rdiff6,pep_aa_tube
18805 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18806 !C now we calculate gradient
18807        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
18808             6.0d0*pep_bb_tube)/rdiff6/rdiff
18809 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18810 !C     &rdiff,fac
18811          if (acavtubpep.eq.0.0d0) then
18812 !C go to 667
18813          enecavtube(i)=0.0
18814          faccav=0.0
18815          else
18816          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
18817          enecavtube(i)=  &
18818         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
18819         /denominator
18820          enecavtube(i)=0.0
18821          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
18822         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
18823         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
18824         /denominator**2.0d0
18825 !C         faccav=0.0
18826 !C         fac=fac+faccav
18827 !C 667     continue
18828          endif
18829
18830         do j=1,3
18831         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18832         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18833         enddo
18834         enddo
18835
18836        do i=itube_start,itube_end
18837         enecavtube(i)=0.0d0
18838 !C Lets not jump over memory as we use many times iti
18839          iti=itype(i)
18840 !C lets ommit dummy atoms for now
18841          if ((iti.eq.ntyp1) &
18842 !C in UNRES uncomment the line below as GLY has no side-chain...
18843 !C      .or.(iti.eq.10)
18844          ) cycle
18845       xmin=boxxsize
18846       ymin=boxysize
18847       zmin=boxzsize
18848         do j=-1,1
18849          vectube(1)=dmod((c(1,i+nres)),boxxsize)
18850          vectube(1)=vectube(1)+boxxsize*j
18851          vectube(2)=dmod((c(2,i+nres)),boxysize)
18852          vectube(2)=vectube(2)+boxysize*j
18853          vectube(3)=dmod((c(3,i+nres)),boxzsize)
18854          vectube(3)=vectube(3)+boxzsize*j
18855
18856
18857          xminact=dabs(vectube(1)-tubecenter(1))
18858          yminact=dabs(vectube(2)-tubecenter(2))
18859          zminact=dabs(vectube(3)-tubecenter(3))
18860
18861            if (xmin.gt.xminact) then
18862             xmin=xminact
18863             xtemp=vectube(1)
18864            endif
18865            if (ymin.gt.yminact) then
18866              ymin=yminact
18867              ytemp=vectube(2)
18868             endif
18869            if (zmin.gt.zminact) then
18870              zmin=zminact
18871              ztemp=vectube(3)
18872             endif
18873          enddo
18874       vectube(1)=xtemp
18875       vectube(2)=ytemp
18876       vectube(3)=ztemp
18877
18878 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18879 !C     &     tubecenter(2)
18880       vectube(1)=vectube(1)-tubecenter(1)
18881       vectube(2)=vectube(2)-tubecenter(2)
18882       vectube(3)=vectube(3)-tubecenter(3)
18883 !C now calculte the distance
18884        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18885 !C now normalize vector
18886       vectube(1)=vectube(1)/tub_r
18887       vectube(2)=vectube(2)/tub_r
18888       vectube(3)=vectube(3)/tub_r
18889
18890 !C calculte rdiffrence between r and r0
18891       rdiff=tub_r-tubeR0
18892 !C and its 6 power
18893       rdiff6=rdiff**6.0d0
18894        sc_aa_tube=sc_aa_tube_par(iti)
18895        sc_bb_tube=sc_bb_tube_par(iti)
18896        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18897 !C       enetube(i+nres)=0.0d0
18898 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18899 !C now we calculate gradient
18900        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
18901             6.0d0*sc_bb_tube/rdiff6/rdiff
18902 !C       fac=0.0
18903 !C now direction of gg_tube vector
18904 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
18905          if (acavtub(iti).eq.0.0d0) then
18906 !C go to 667
18907          enecavtube(i+nres)=0.0d0
18908          faccav=0.0d0
18909          else
18910          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
18911          enecavtube(i+nres)=   &
18912         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
18913         /denominator
18914 !C         enecavtube(i)=0.0
18915          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
18916         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
18917         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
18918         /denominator**2.0d0
18919 !C         faccav=0.0
18920          fac=fac+faccav
18921 !C 667     continue
18922          endif
18923 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
18924 !C     &   enecavtube(i),faccav
18925 !C         print *,"licz=",
18926 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
18927 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
18928          do j=1,3
18929           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18930           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18931          enddo
18932         enddo
18933
18934
18935
18936         do i=itube_start,itube_end
18937           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
18938          +enecavtube(i+nres)
18939         enddo
18940 !C        print *,"ETUBE", etube
18941         return
18942         end subroutine calcnano
18943
18944 !===============================================
18945 !--------------------------------------------------------------------------------
18946 !C first for shielding is setting of function of side-chains
18947
18948        subroutine set_shield_fac2
18949        real(kind=8) :: div77_81=0.974996043d0, &
18950         div4_81=0.2222222222d0
18951        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
18952          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
18953          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
18954          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
18955 !C the vector between center of side_chain and peptide group
18956        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
18957          pept_group,costhet_grad,cosphi_grad_long, &
18958          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
18959          sh_frac_dist_grad,pep_side
18960         integer i,j,k
18961 !C      write(2,*) "ivec",ivec_start,ivec_end
18962       do i=1,nres
18963         fac_shield(i)=0.0d0
18964         do j=1,3
18965         grad_shield(j,i)=0.0d0
18966         enddo
18967       enddo
18968       do i=ivec_start,ivec_end
18969 !C      do i=1,nres-1
18970 !C      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
18971       ishield_list(i)=0
18972       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
18973 !Cif there two consequtive dummy atoms there is no peptide group between them
18974 !C the line below has to be changed for FGPROC>1
18975       VolumeTotal=0.0
18976       do k=1,nres
18977        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
18978        dist_pep_side=0.0
18979        dist_side_calf=0.0
18980        do j=1,3
18981 !C first lets set vector conecting the ithe side-chain with kth side-chain
18982       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
18983 !C      pep_side(j)=2.0d0
18984 !C and vector conecting the side-chain with its proper calfa
18985       side_calf(j)=c(j,k+nres)-c(j,k)
18986 !C      side_calf(j)=2.0d0
18987       pept_group(j)=c(j,i)-c(j,i+1)
18988 !C lets have their lenght
18989       dist_pep_side=pep_side(j)**2+dist_pep_side
18990       dist_side_calf=dist_side_calf+side_calf(j)**2
18991       dist_pept_group=dist_pept_group+pept_group(j)**2
18992       enddo
18993        dist_pep_side=sqrt(dist_pep_side)
18994        dist_pept_group=sqrt(dist_pept_group)
18995        dist_side_calf=sqrt(dist_side_calf)
18996       do j=1,3
18997         pep_side_norm(j)=pep_side(j)/dist_pep_side
18998         side_calf_norm(j)=dist_side_calf
18999       enddo
19000 !C now sscale fraction
19001        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19002 !C       print *,buff_shield,"buff"
19003 !C now sscale
19004         if (sh_frac_dist.le.0.0) cycle
19005 !C        print *,ishield_list(i),i
19006 !C If we reach here it means that this side chain reaches the shielding sphere
19007 !C Lets add him to the list for gradient
19008         ishield_list(i)=ishield_list(i)+1
19009 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19010 !C this list is essential otherwise problem would be O3
19011         shield_list(ishield_list(i),i)=k
19012 !C Lets have the sscale value
19013         if (sh_frac_dist.gt.1.0) then
19014          scale_fac_dist=1.0d0
19015          do j=1,3
19016          sh_frac_dist_grad(j)=0.0d0
19017          enddo
19018         else
19019          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19020                         *(2.0d0*sh_frac_dist-3.0d0)
19021          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19022                        /dist_pep_side/buff_shield*0.5d0
19023          do j=1,3
19024          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19025 !C         sh_frac_dist_grad(j)=0.0d0
19026 !C         scale_fac_dist=1.0d0
19027 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19028 !C     &                    sh_frac_dist_grad(j)
19029          enddo
19030         endif
19031 !C this is what is now we have the distance scaling now volume...
19032       short=short_r_sidechain(itype(k))
19033       long=long_r_sidechain(itype(k))
19034       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19035       sinthet=short/dist_pep_side*costhet
19036 !C now costhet_grad
19037 !C       costhet=0.6d0
19038 !C       sinthet=0.8
19039        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19040 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19041 !C     &             -short/dist_pep_side**2/costhet)
19042 !C       costhet_fac=0.0d0
19043        do j=1,3
19044          costhet_grad(j)=costhet_fac*pep_side(j)
19045        enddo
19046 !C remember for the final gradient multiply costhet_grad(j)
19047 !C for side_chain by factor -2 !
19048 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19049 !C pep_side0pept_group is vector multiplication
19050       pep_side0pept_group=0.0d0
19051       do j=1,3
19052       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19053       enddo
19054       cosalfa=(pep_side0pept_group/ &
19055       (dist_pep_side*dist_side_calf))
19056       fac_alfa_sin=1.0d0-cosalfa**2
19057       fac_alfa_sin=dsqrt(fac_alfa_sin)
19058       rkprim=fac_alfa_sin*(long-short)+short
19059 !C      rkprim=short
19060
19061 !C now costhet_grad
19062        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19063 !C       cosphi=0.6
19064        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19065        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19066            dist_pep_side**2)
19067 !C       sinphi=0.8
19068        do j=1,3
19069          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19070       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19071       *(long-short)/fac_alfa_sin*cosalfa/ &
19072       ((dist_pep_side*dist_side_calf))* &
19073       ((side_calf(j))-cosalfa* &
19074       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19075 !C       cosphi_grad_long(j)=0.0d0
19076         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19077       *(long-short)/fac_alfa_sin*cosalfa &
19078       /((dist_pep_side*dist_side_calf))* &
19079       (pep_side(j)- &
19080       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19081 !C       cosphi_grad_loc(j)=0.0d0
19082        enddo
19083 !C      print *,sinphi,sinthet
19084       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19085      &                    /VSolvSphere_div
19086 !C     &                    *wshield
19087 !C now the gradient...
19088       do j=1,3
19089       grad_shield(j,i)=grad_shield(j,i) &
19090 !C gradient po skalowaniu
19091                      +(sh_frac_dist_grad(j)*VofOverlap &
19092 !C  gradient po costhet
19093             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19094         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19095             sinphi/sinthet*costhet*costhet_grad(j) &
19096            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19097         )*wshield
19098 !C grad_shield_side is Cbeta sidechain gradient
19099       grad_shield_side(j,ishield_list(i),i)=&
19100              (sh_frac_dist_grad(j)*-2.0d0&
19101              *VofOverlap&
19102             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19103        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19104             sinphi/sinthet*costhet*costhet_grad(j)&
19105            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19106             )*wshield
19107
19108        grad_shield_loc(j,ishield_list(i),i)=   &
19109             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19110       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19111             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19112              ))&
19113              *wshield
19114       enddo
19115       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19116       enddo
19117       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19118
19119 !C      write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
19120       enddo
19121       return
19122       end subroutine set_shield_fac2
19123 !----------------------------------------------------------------------------
19124 ! SOUBROUTINE FOR AFM
19125        subroutine AFMvel(Eafmforce)
19126        use MD_data, only:totTafm
19127       real(kind=8),dimension(3) :: diffafm
19128       real(kind=8) :: afmdist,Eafmforce
19129        integer :: i
19130 !C Only for check grad COMMENT if not used for checkgrad
19131 !C      totT=3.0d0
19132 !C--------------------------------------------------------
19133 !C      print *,"wchodze"
19134       afmdist=0.0d0
19135       Eafmforce=0.0d0
19136       do i=1,3
19137       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19138       afmdist=afmdist+diffafm(i)**2
19139       enddo
19140       afmdist=dsqrt(afmdist)
19141 !      totTafm=3.0
19142       Eafmforce=0.5d0*forceAFMconst &
19143       *(distafminit+totTafm*velAFMconst-afmdist)**2
19144 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19145       do i=1,3
19146       gradafm(i,afmend-1)=-forceAFMconst* &
19147        (distafminit+totTafm*velAFMconst-afmdist) &
19148        *diffafm(i)/afmdist
19149       gradafm(i,afmbeg-1)=forceAFMconst* &
19150       (distafminit+totTafm*velAFMconst-afmdist) &
19151       *diffafm(i)/afmdist
19152       enddo
19153 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19154       return
19155       end subroutine AFMvel
19156 !---------------------------------------------------------
19157        subroutine AFMforce(Eafmforce)
19158
19159       real(kind=8),dimension(3) :: diffafm
19160 !      real(kind=8) ::afmdist
19161       real(kind=8) :: afmdist,Eafmforce
19162       integer :: i
19163       afmdist=0.0d0
19164       Eafmforce=0.0d0
19165       do i=1,3
19166       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19167       afmdist=afmdist+diffafm(i)**2
19168       enddo
19169       afmdist=dsqrt(afmdist)
19170 !      print *,afmdist,distafminit
19171       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19172       do i=1,3
19173       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19174       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19175       enddo
19176 !C      print *,'AFM',Eafmforce
19177       return
19178       end subroutine AFMforce
19179
19180 !-----------------------------------------------------------------------------
19181 #ifdef WHAM
19182       subroutine read_ssHist
19183 !      implicit none
19184 !      Includes
19185 !      include 'DIMENSIONS'
19186 !      include "DIMENSIONS.FREE"
19187 !      include 'COMMON.FREE'
19188 !     Local variables
19189       integer :: i,j
19190       character(len=80) :: controlcard
19191
19192       do i=1,dyn_nssHist
19193         call card_concat(controlcard,.true.)
19194         read(controlcard,*) &
19195              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19196       enddo
19197
19198       return
19199       end subroutine read_ssHist
19200 #endif
19201 !-----------------------------------------------------------------------------
19202       integer function indmat(i,j)
19203 !el
19204 ! get the position of the jth ijth fragment of the chain coordinate system
19205 ! in the fromto array.
19206         integer :: i,j
19207
19208         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19209       return
19210       end function indmat
19211 !-----------------------------------------------------------------------------
19212       real(kind=8) function sigm(x)
19213 !el
19214        real(kind=8) :: x
19215         sigm=0.25d0*x
19216       return
19217       end function sigm
19218 !-----------------------------------------------------------------------------
19219 !-----------------------------------------------------------------------------
19220       subroutine alloc_ener_arrays
19221 !EL Allocation of arrays used by module energy
19222       use MD_data, only: mset
19223 !el local variables
19224       integer :: i,j
19225
19226       if(nres.lt.100) then
19227         maxconts=nres
19228       elseif(nres.lt.200) then
19229         maxconts=0.8*nres       ! Max. number of contacts per residue
19230       else
19231         maxconts=0.6*nres ! (maxconts=maxres/4)
19232       endif
19233       maxcont=12*nres   ! Max. number of SC contacts
19234       maxvar=6*nres     ! Max. number of variables
19235 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19236       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19237 !----------------------
19238 ! arrays in subroutine init_int_table
19239 !el#ifdef MPI
19240 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19241 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19242 !el#endif
19243       allocate(nint_gr(nres))
19244       allocate(nscp_gr(nres))
19245       allocate(ielstart(nres))
19246       allocate(ielend(nres))
19247 !(maxres)
19248       allocate(istart(nres,maxint_gr))
19249       allocate(iend(nres,maxint_gr))
19250 !(maxres,maxint_gr)
19251       allocate(iscpstart(nres,maxint_gr))
19252       allocate(iscpend(nres,maxint_gr))
19253 !(maxres,maxint_gr)
19254       allocate(ielstart_vdw(nres))
19255       allocate(ielend_vdw(nres))
19256 !(maxres)
19257
19258       allocate(lentyp(0:nfgtasks-1))
19259 !(0:maxprocs-1)
19260 !----------------------
19261 ! commom.contacts
19262 !      common /contacts/
19263       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19264       allocate(icont(2,maxcont))
19265 !(2,maxcont)
19266 !      common /contacts1/
19267       allocate(num_cont(0:nres+4))
19268 !(maxres)
19269       allocate(jcont(maxconts,nres))
19270 !(maxconts,maxres)
19271       allocate(facont(maxconts,nres))
19272 !(maxconts,maxres)
19273       allocate(gacont(3,maxconts,nres))
19274 !(3,maxconts,maxres)
19275 !      common /contacts_hb/
19276       allocate(gacontp_hb1(3,maxconts,nres))
19277       allocate(gacontp_hb2(3,maxconts,nres))
19278       allocate(gacontp_hb3(3,maxconts,nres))
19279       allocate(gacontm_hb1(3,maxconts,nres))
19280       allocate(gacontm_hb2(3,maxconts,nres))
19281       allocate(gacontm_hb3(3,maxconts,nres))
19282       allocate(gacont_hbr(3,maxconts,nres))
19283       allocate(grij_hb_cont(3,maxconts,nres))
19284 !(3,maxconts,maxres)
19285       allocate(facont_hb(maxconts,nres))
19286
19287       allocate(ees0p(maxconts,nres))
19288       allocate(ees0m(maxconts,nres))
19289       allocate(d_cont(maxconts,nres))
19290       allocate(ees0plist(maxconts,nres))
19291
19292 !(maxconts,maxres)
19293       allocate(num_cont_hb(nres))
19294 !(maxres)
19295       allocate(jcont_hb(maxconts,nres))
19296 !(maxconts,maxres)
19297 !      common /rotat/
19298       allocate(Ug(2,2,nres))
19299       allocate(Ugder(2,2,nres))
19300       allocate(Ug2(2,2,nres))
19301       allocate(Ug2der(2,2,nres))
19302 !(2,2,maxres)
19303       allocate(obrot(2,nres))
19304       allocate(obrot2(2,nres))
19305       allocate(obrot_der(2,nres))
19306       allocate(obrot2_der(2,nres))
19307 !(2,maxres)
19308 !      common /precomp1/
19309       allocate(mu(2,nres))
19310       allocate(muder(2,nres))
19311       allocate(Ub2(2,nres))
19312       Ub2(1,:)=0.0d0
19313       Ub2(2,:)=0.0d0
19314       allocate(Ub2der(2,nres))
19315       allocate(Ctobr(2,nres))
19316       allocate(Ctobrder(2,nres))
19317       allocate(Dtobr2(2,nres))
19318       allocate(Dtobr2der(2,nres))
19319 !(2,maxres)
19320       allocate(EUg(2,2,nres))
19321       allocate(EUgder(2,2,nres))
19322       allocate(CUg(2,2,nres))
19323       allocate(CUgder(2,2,nres))
19324       allocate(DUg(2,2,nres))
19325       allocate(Dugder(2,2,nres))
19326       allocate(DtUg2(2,2,nres))
19327       allocate(DtUg2der(2,2,nres))
19328 !(2,2,maxres)
19329 !      common /precomp2/
19330       allocate(Ug2Db1t(2,nres))
19331       allocate(Ug2Db1tder(2,nres))
19332       allocate(CUgb2(2,nres))
19333       allocate(CUgb2der(2,nres))
19334 !(2,maxres)
19335       allocate(EUgC(2,2,nres))
19336       allocate(EUgCder(2,2,nres))
19337       allocate(EUgD(2,2,nres))
19338       allocate(EUgDder(2,2,nres))
19339       allocate(DtUg2EUg(2,2,nres))
19340       allocate(Ug2DtEUg(2,2,nres))
19341 !(2,2,maxres)
19342       allocate(Ug2DtEUgder(2,2,2,nres))
19343       allocate(DtUg2EUgder(2,2,2,nres))
19344 !(2,2,2,maxres)
19345 !      common /rotat_old/
19346       allocate(costab(nres))
19347       allocate(sintab(nres))
19348       allocate(costab2(nres))
19349       allocate(sintab2(nres))
19350 !(maxres)
19351 !      common /dipmat/
19352       allocate(a_chuj(2,2,maxconts,nres))
19353 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19354       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19355 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19356 !      common /contdistrib/
19357       allocate(ncont_sent(nres))
19358       allocate(ncont_recv(nres))
19359
19360       allocate(iat_sent(nres))
19361 !(maxres)
19362       allocate(iint_sent(4,nres,nres))
19363       allocate(iint_sent_local(4,nres,nres))
19364 !(4,maxres,maxres)
19365       allocate(iturn3_sent(4,0:nres+4))
19366       allocate(iturn4_sent(4,0:nres+4))
19367       allocate(iturn3_sent_local(4,nres))
19368       allocate(iturn4_sent_local(4,nres))
19369 !(4,maxres)
19370       allocate(itask_cont_from(0:nfgtasks-1))
19371       allocate(itask_cont_to(0:nfgtasks-1))
19372 !(0:max_fg_procs-1)
19373
19374
19375
19376 !----------------------
19377 ! commom.deriv;
19378 !      common /derivat/
19379       allocate(dcdv(6,maxdim))
19380       allocate(dxdv(6,maxdim))
19381 !(6,maxdim)
19382       allocate(dxds(6,nres))
19383 !(6,maxres)
19384       allocate(gradx(3,-1:nres,0:2))
19385       allocate(gradc(3,-1:nres,0:2))
19386 !(3,maxres,2)
19387       allocate(gvdwx(3,-1:nres))
19388       allocate(gvdwc(3,-1:nres))
19389       allocate(gelc(3,-1:nres))
19390       allocate(gelc_long(3,-1:nres))
19391       allocate(gvdwpp(3,-1:nres))
19392       allocate(gvdwc_scpp(3,-1:nres))
19393       allocate(gradx_scp(3,-1:nres))
19394       allocate(gvdwc_scp(3,-1:nres))
19395       allocate(ghpbx(3,-1:nres))
19396       allocate(ghpbc(3,-1:nres))
19397       allocate(gradcorr(3,-1:nres))
19398       allocate(gradcorr_long(3,-1:nres))
19399       allocate(gradcorr5_long(3,-1:nres))
19400       allocate(gradcorr6_long(3,-1:nres))
19401       allocate(gcorr6_turn_long(3,-1:nres))
19402       allocate(gradxorr(3,-1:nres))
19403       allocate(gradcorr5(3,-1:nres))
19404       allocate(gradcorr6(3,-1:nres))
19405       allocate(gliptran(3,-1:nres))
19406       allocate(gliptranc(3,-1:nres))
19407       allocate(gliptranx(3,-1:nres))
19408       allocate(gshieldx(3,-1:nres))
19409       allocate(gshieldc(3,-1:nres))
19410       allocate(gshieldc_loc(3,-1:nres))
19411       allocate(gshieldx_ec(3,-1:nres))
19412       allocate(gshieldc_ec(3,-1:nres))
19413       allocate(gshieldc_loc_ec(3,-1:nres))
19414       allocate(gshieldx_t3(3,-1:nres))
19415       allocate(gshieldc_t3(3,-1:nres))
19416       allocate(gshieldc_loc_t3(3,-1:nres))
19417       allocate(gshieldx_t4(3,-1:nres))
19418       allocate(gshieldc_t4(3,-1:nres))
19419       allocate(gshieldc_loc_t4(3,-1:nres))
19420       allocate(gshieldx_ll(3,-1:nres))
19421       allocate(gshieldc_ll(3,-1:nres))
19422       allocate(gshieldc_loc_ll(3,-1:nres))
19423       allocate(grad_shield(3,-1:nres))
19424       allocate(gg_tube_sc(3,-1:nres))
19425       allocate(gg_tube(3,-1:nres))
19426       allocate(gradafm(3,-1:nres))
19427 !(3,maxres)
19428       allocate(grad_shield_side(3,50,nres))
19429       allocate(grad_shield_loc(3,50,nres))
19430 ! grad for shielding surroing
19431       allocate(gloc(0:maxvar,0:2))
19432       allocate(gloc_x(0:maxvar,2))
19433 !(maxvar,2)
19434       allocate(gel_loc(3,-1:nres))
19435       allocate(gel_loc_long(3,-1:nres))
19436       allocate(gcorr3_turn(3,-1:nres))
19437       allocate(gcorr4_turn(3,-1:nres))
19438       allocate(gcorr6_turn(3,-1:nres))
19439       allocate(gradb(3,-1:nres))
19440       allocate(gradbx(3,-1:nres))
19441 !(3,maxres)
19442       allocate(gel_loc_loc(maxvar))
19443       allocate(gel_loc_turn3(maxvar))
19444       allocate(gel_loc_turn4(maxvar))
19445       allocate(gel_loc_turn6(maxvar))
19446       allocate(gcorr_loc(maxvar))
19447       allocate(g_corr5_loc(maxvar))
19448       allocate(g_corr6_loc(maxvar))
19449 !(maxvar)
19450       allocate(gsccorc(3,-1:nres))
19451       allocate(gsccorx(3,-1:nres))
19452 !(3,maxres)
19453       allocate(gsccor_loc(-1:nres))
19454 !(maxres)
19455       allocate(dtheta(3,2,-1:nres))
19456 !(3,2,maxres)
19457       allocate(gscloc(3,-1:nres))
19458       allocate(gsclocx(3,-1:nres))
19459 !(3,maxres)
19460       allocate(dphi(3,3,-1:nres))
19461       allocate(dalpha(3,3,-1:nres))
19462       allocate(domega(3,3,-1:nres))
19463 !(3,3,maxres)
19464 !      common /deriv_scloc/
19465       allocate(dXX_C1tab(3,nres))
19466       allocate(dYY_C1tab(3,nres))
19467       allocate(dZZ_C1tab(3,nres))
19468       allocate(dXX_Ctab(3,nres))
19469       allocate(dYY_Ctab(3,nres))
19470       allocate(dZZ_Ctab(3,nres))
19471       allocate(dXX_XYZtab(3,nres))
19472       allocate(dYY_XYZtab(3,nres))
19473       allocate(dZZ_XYZtab(3,nres))
19474 !(3,maxres)
19475 !      common /mpgrad/
19476       allocate(jgrad_start(nres))
19477       allocate(jgrad_end(nres))
19478 !(maxres)
19479 !----------------------
19480
19481 !      common /indices/
19482       allocate(ibond_displ(0:nfgtasks-1))
19483       allocate(ibond_count(0:nfgtasks-1))
19484       allocate(ithet_displ(0:nfgtasks-1))
19485       allocate(ithet_count(0:nfgtasks-1))
19486       allocate(iphi_displ(0:nfgtasks-1))
19487       allocate(iphi_count(0:nfgtasks-1))
19488       allocate(iphi1_displ(0:nfgtasks-1))
19489       allocate(iphi1_count(0:nfgtasks-1))
19490       allocate(ivec_displ(0:nfgtasks-1))
19491       allocate(ivec_count(0:nfgtasks-1))
19492       allocate(iset_displ(0:nfgtasks-1))
19493       allocate(iset_count(0:nfgtasks-1))
19494       allocate(iint_count(0:nfgtasks-1))
19495       allocate(iint_displ(0:nfgtasks-1))
19496 !(0:max_fg_procs-1)
19497 !----------------------
19498 ! common.MD
19499 !      common /mdgrad/
19500       allocate(gcart(3,-1:nres))
19501       allocate(gxcart(3,-1:nres))
19502 !(3,0:MAXRES)
19503       allocate(gradcag(3,-1:nres))
19504       allocate(gradxag(3,-1:nres))
19505 !(3,MAXRES)
19506 !      common /back_constr/
19507 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19508       allocate(dutheta(nres))
19509       allocate(dugamma(nres))
19510 !(maxres)
19511       allocate(duscdiff(3,nres))
19512       allocate(duscdiffx(3,nres))
19513 !(3,maxres)
19514 !el i io:read_fragments
19515 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19516 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19517 !      common /qmeas/
19518 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19519 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19520       allocate(mset(0:nprocs))  !(maxprocs/20)
19521       mset(:)=0
19522 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19523 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19524       allocate(dUdconst(3,0:nres))
19525       allocate(dUdxconst(3,0:nres))
19526       allocate(dqwol(3,0:nres))
19527       allocate(dxqwol(3,0:nres))
19528 !(3,0:MAXRES)
19529 !----------------------
19530 ! common.sbridge
19531 !      common /sbridge/ in io_common: read_bridge
19532 !el    allocate((:),allocatable :: iss  !(maxss)
19533 !      common /links/  in io_common: read_bridge
19534 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19535 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19536 !      common /dyn_ssbond/
19537 ! and side-chain vectors in theta or phi.
19538       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19539 !(maxres,maxres)
19540 !      do i=1,nres
19541 !        do j=i+1,nres
19542       dyn_ssbond_ij(:,:)=1.0d300
19543 !        enddo
19544 !      enddo
19545
19546 !      if (nss.gt.0) then
19547         allocate(idssb(maxdim),jdssb(maxdim))
19548 !        allocate(newihpb(nss),newjhpb(nss))
19549 !(maxdim)
19550 !      endif
19551       allocate(ishield_list(nres))
19552       allocate(shield_list(50,nres))
19553       allocate(dyn_ss_mask(nres))
19554       allocate(fac_shield(nres))
19555 !(maxres)
19556       dyn_ss_mask(:)=.false.
19557 !----------------------
19558 ! common.sccor
19559 ! Parameters of the SCCOR term
19560 !      common/sccor/
19561 !el in io_conf: parmread
19562 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
19563 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
19564 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
19565 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
19566 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
19567 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
19568 !      allocate(vlor1sccor(maxterm_sccor,20,20))
19569 !      allocate(vlor2sccor(maxterm_sccor,20,20))
19570 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
19571 !----------------
19572       allocate(gloc_sc(3,0:2*nres,0:10))
19573 !(3,0:maxres2,10)maxres2=2*maxres
19574       allocate(dcostau(3,3,3,2*nres))
19575       allocate(dsintau(3,3,3,2*nres))
19576       allocate(dtauangle(3,3,3,2*nres))
19577       allocate(dcosomicron(3,3,3,2*nres))
19578       allocate(domicron(3,3,3,2*nres))
19579 !(3,3,3,maxres2)maxres2=2*maxres
19580 !----------------------
19581 ! common.var
19582 !      common /restr/
19583       allocate(varall(maxvar))
19584 !(maxvar)(maxvar=6*maxres)
19585       allocate(mask_theta(nres))
19586       allocate(mask_phi(nres))
19587       allocate(mask_side(nres))
19588 !(maxres)
19589 !----------------------
19590 ! common.vectors
19591 !      common /vectors/
19592       allocate(uy(3,nres))
19593       allocate(uz(3,nres))
19594 !(3,maxres)
19595       allocate(uygrad(3,3,2,nres))
19596       allocate(uzgrad(3,3,2,nres))
19597 !(3,3,2,maxres)
19598
19599       return
19600       end subroutine alloc_ener_arrays
19601 !-----------------------------------------------------------------------------
19602 !-----------------------------------------------------------------------------
19603       end module energy