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       real(kind=8),dimension(:),allocatable :: enetube,enecavtube
  49 !
  50 ! 12/26/95 - H-bonding contacts
  51 !      common /contacts_hb/
  52       real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,&
  53        gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont  !(3,maxconts,maxres)
  54       real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,&
  55         ees0m,d_cont    !(maxconts,maxres)
  56       integer,dimension(:),allocatable :: num_cont_hb   !(maxres)
  57       integer,dimension(:,:),allocatable :: jcont_hb    !(maxconts,maxres)
  58 ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
  59 !         interactions
  60 ! 7/25/08 commented out; not needed when cumulants used
  61 ! Interactions of pseudo-dipoles generated by loc-el interactions.
  62 !  common /dipint/
  63       real(kind=8),dimension(:,:,:),allocatable :: dip,&
  64          dipderg        !(4,maxconts,maxres)
  65       real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres)
  66 ! 10/30/99 Added other pre-computed vectors and matrices needed
  67 !          to calculate three - six-order el-loc correlation terms
  68 ! common /rotat/
  69       real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der  !(2,2,maxres)
  70       real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,&
  71        obrot2_der       !(2,maxres)
  72 !
  73 ! This common block contains vectors and matrices dependent on a single
  74 ! amino-acid residue.
  75 !      common /precomp1/
  76       real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,&
  77        Ctobr,Ctobrder,Dtobr2,Dtobr2der  !(2,maxres)
  78       real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,&
  79        CUgder,DUg,Dugder,DtUg2,DtUg2der !(2,2,maxres)
  80 ! This common block contains vectors and matrices dependent on two
  81 ! consecutive amino-acid residues.
  82 !      common /precomp2/
  83       real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,&
  84        CUgb2,CUgb2der   !(2,maxres)
  85       real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,&
  86        EUgD,EUgDder,DtUg2EUg,Ug2DtEUg   !(2,2,maxres)
  87       real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,&
  88        DtUg2EUgder      !(2,2,2,maxres)
  89 !      common /rotat_old/
  90       real(kind=8),dimension(:),allocatable :: costab,sintab,&
  91        costab2,sintab2  !(maxres)
  92 ! This common block contains dipole-interaction matrices and their
  93 ! Cartesian derivatives.
  94 !      common /dipmat/
  95       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj     !(2,2,maxconts,maxres)
  96       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der     !(2,2,3,5,maxconts,maxres)
  97 !      common /diploc/
  98       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
  99        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
 100       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
 101        ADtEA1derg,AEAb2derg
 102       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
 103        AECAderx,ADtEAderx,ADtEA1derx
 104       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
 105       real(kind=8),dimension(3,2) :: g_contij
 106       real(kind=8) :: ekont
 107 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 108 !   RE: Parallelization of 4th and higher order loc-el correlations
 109 !      common /contdistrib/
 110       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 111 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 112 !-----------------------------------------------------------------------------
 113 ! commom.deriv;
 114 !      common /derivat/
 115 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 116 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 117 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 118       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 119         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 120         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 121         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6,gliptran,gliptranc,&
 122         gliptranx, &
 123         gshieldx,gshieldc,gshieldc_loc,gshieldx_ec,&
 124         gshieldc_ec,gshieldc_loc_ec,gshieldx_t3, &
 125         gshieldc_t3,gshieldc_loc_t3,gshieldx_t4,gshieldc_t4, &
 126         gshieldc_loc_t4,gshieldx_ll,gshieldc_ll,gshieldc_loc_ll,&
 127         grad_shield,gg_tube,gg_tube_sc,gradafm !(3,maxres)
 128 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 129       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 130         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 131       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 132         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 133         g_corr6_loc     !(maxvar)
 134       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 135       real(kind=8),dimension(:),allocatable :: gsccor_loc       !(maxres)
 136 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 137       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 138 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 139       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 140          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 141 !      integer :: nfl,icg
 142 !      common /deriv_loc/
 143       real(kind=8), dimension(:),allocatable :: fac_shield
 144       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 145 !      common /deriv_scloc/
 146       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 147        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 148        dZZ_XYZtab       !(3,maxres)
 149 !-----------------------------------------------------------------------------
 150 ! common.maxgrad
 151 !      common /maxgrad/
 152       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 153        gradb_max,ghpbc_max,&
 154        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 155        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 156        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 157        gsccorx_max,gsclocx_max
 158 !-----------------------------------------------------------------------------
 159 ! common.MD
 160 !      common /back_constr/
 161       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 162       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 163 !      common /qmeas/
 164       real(kind=8) :: Ucdfrag,Ucdpair
 165       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 166        dqwol,dxqwol     !(3,0:MAXRES)
 167 !-----------------------------------------------------------------------------
 168 ! common.sbridge
 169 !      common /dyn_ssbond/
 170       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 171 !-----------------------------------------------------------------------------
 172 ! common.sccor
 173 ! Parameters of the SCCOR term
 174 !      common/sccor/
 175       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 176        dcosomicron,domicron     !(3,3,3,maxres2)
 177 !-----------------------------------------------------------------------------
 178 ! common.vectors
 179 !      common /vectors/
 180       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 181       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 182 !-----------------------------------------------------------------------------
 183 ! common /przechowalnia/
 184       real(kind=8),dimension(:,:,:),allocatable :: zapas !(max_dim,maxconts,max_fg_procs)
 185       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 186 !-----------------------------------------------------------------------------
 187 !-----------------------------------------------------------------------------
 188 !
 189 !
 190 !-----------------------------------------------------------------------------
 191       contains
 192 !-----------------------------------------------------------------------------
 193 ! energy_p_new_barrier.F
 194 !-----------------------------------------------------------------------------
 195       subroutine etotal(energia)
 196 !      implicit real*8 (a-h,o-z)
 197 !      include 'DIMENSIONS'
 198       use MD_data
 199 #ifndef ISNAN
 200       external proc_proc
 201 #ifdef WINPGI
 202 !MS$ATTRIBUTES C ::  proc_proc
 203 #endif
 204 #endif
 205 #ifdef MPI
 206       include "mpif.h"
 207 #endif
 208 !      include 'COMMON.SETUP'
 209 !      include 'COMMON.IOUNITS'
 210       real(kind=8),dimension(0:n_ene) :: energia
 211 !      include 'COMMON.LOCAL'
 212 !      include 'COMMON.FFIELD'
 213 !      include 'COMMON.DERIV'
 214 !      include 'COMMON.INTERACT'
 215 !      include 'COMMON.SBRIDGE'
 216 !      include 'COMMON.CHAIN'
 217 !      include 'COMMON.VAR'
 218 !      include 'COMMON.MD'
 219 !      include 'COMMON.CONTROL'
 220 !      include 'COMMON.TIME1'
 221       real(kind=8) :: time00
 222 !el local variables
 223       integer :: n_corr,n_corr1,ierror
 224       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 225       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 226       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 227                       Eafmforce,ethetacnstr
 228       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 229
 230 #ifdef MPI
 231       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 232 ! shielding effect varibles for MPI
 233 !      real(kind=8)   fac_shieldbuf(maxres),
 234 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 235 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 236 !     & grad_shieldbuf(3,-1:maxres)
 237 !       integer ishield_listbuf(maxres),
 238 !     &shield_listbuf(maxcontsshi,maxres)
 239
 240 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 241 !     & " nfgtasks",nfgtasks
 242       if (nfgtasks.gt.1) then
 243         time00=MPI_Wtime()
 244 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 245         if (fg_rank.eq.0) then
 246           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 247 !          print *,"Processor",myrank," BROADCAST iorder"
 248 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 249 ! FG slaves as WEIGHTS array.
 250           weights_(1)=wsc
 251           weights_(2)=wscp
 252           weights_(3)=welec
 253           weights_(4)=wcorr
 254           weights_(5)=wcorr5
 255           weights_(6)=wcorr6
 256           weights_(7)=wel_loc
 257           weights_(8)=wturn3
 258           weights_(9)=wturn4
 259           weights_(10)=wturn6
 260           weights_(11)=wang
 261           weights_(12)=wscloc
 262           weights_(13)=wtor
 263           weights_(14)=wtor_d
 264           weights_(15)=wstrain
 265           weights_(16)=wvdwpp
 266           weights_(17)=wbond
 267           weights_(18)=scal14
 268           weights_(21)=wsccor
 269 ! FG Master broadcasts the WEIGHTS_ array
 270           call MPI_Bcast(weights_(1),n_ene,&
 271              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 272         else
 273 ! FG slaves receive the WEIGHTS array
 274           call MPI_Bcast(weights(1),n_ene,&
 275               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 276           wsc=weights(1)
 277           wscp=weights(2)
 278           welec=weights(3)
 279           wcorr=weights(4)
 280           wcorr5=weights(5)
 281           wcorr6=weights(6)
 282           wel_loc=weights(7)
 283           wturn3=weights(8)
 284           wturn4=weights(9)
 285           wturn6=weights(10)
 286           wang=weights(11)
 287           wscloc=weights(12)
 288           wtor=weights(13)
 289           wtor_d=weights(14)
 290           wstrain=weights(15)
 291           wvdwpp=weights(16)
 292           wbond=weights(17)
 293           scal14=weights(18)
 294           wsccor=weights(21)
 295         endif
 296         time_Bcast=time_Bcast+MPI_Wtime()-time00
 297         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 298 !        call chainbuild_cart
 299       endif
 300 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 301 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 302 #else
 303 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 304 !        call int_from_cart1(.false.)
 305 !      endif
 306 #endif
 307 #ifdef TIMING
 308       time00=MPI_Wtime()
 309 #endif
 310 !
 311 ! Compute the side-chain and electrostatic interaction energy
 312 !        print *, "Before EVDW"
 313 !      goto (101,102,103,104,105,106) ipot
 314       select case(ipot)
 315 ! Lennard-Jones potential.
 316 !  101 call elj(evdw)
 317        case (1)
 318          call elj(evdw)
 319 !d    print '(a)','Exit ELJcall el'
 320 !      goto 107
 321 ! Lennard-Jones-Kihara potential (shifted).
 322 !  102 call eljk(evdw)
 323        case (2)
 324          call eljk(evdw)
 325 !      goto 107
 326 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 327 !  103 call ebp(evdw)
 328        case (3)
 329          call ebp(evdw)
 330 !      goto 107
 331 ! Gay-Berne potential (shifted LJ, angular dependence).
 332 !  104 call egb(evdw)
 333        case (4)
 334          call egb(evdw)
 335 !      goto 107
 336 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 337 !  105 call egbv(evdw)
 338        case (5)
 339          call egbv(evdw)
 340 !      goto 107
 341 ! Soft-sphere potential
 342 !  106 call e_softsphere(evdw)
 343        case (6)
 344          call e_softsphere(evdw)
 345 !
 346 ! Calculate electrostatic (H-bonding) energy of the main chain.
 347 !
 348 !  107 continue
 349        case default
 350          write(iout,*)"Wrong ipot"
 351 !         return
 352 !   50 continue
 353       end select
 354 !      continue
 355 !        print *,"after EGB"
 356 ! shielding effect
 357        if (shield_mode.eq.2) then
 358                  call set_shield_fac2
 359        endif
 360 !mc
 361 !mc Sep-06: egb takes care of dynamic ss bonds too
 362 !mc
 363 !      if (dyn_ss) call dyn_set_nss
 364 !      print *,"Processor",myrank," computed USCSC"
 365 #ifdef TIMING
 366       time01=MPI_Wtime()
 367 #endif
 368       call vec_and_deriv
 369 #ifdef TIMING
 370       time_vec=time_vec+MPI_Wtime()-time01
 371 #endif
 372 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 373       if (ipot.lt.6) then
 374 #ifdef SPLITELE
 375 !         print *,"after ipot if", ipot
 376          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 377              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 378              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 379              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 380 #else
 381          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 382              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 383              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 384              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 385 #endif
 386 !            print *,"just befor eelec call"
 387             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 388 !         write (iout,*) "ELEC calc"
 389          else
 390             ees=0.0d0
 391             evdw1=0.0d0
 392             eel_loc=0.0d0
 393             eello_turn3=0.0d0
 394             eello_turn4=0.0d0
 395          endif
 396       else
 397 !        write (iout,*) "Soft-spheer ELEC potential"
 398         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 399          eello_turn4)
 400       endif
 401 !      print *,"Processor",myrank," computed UELEC"
 402 !
 403 ! Calculate excluded-volume interaction energy between peptide groups
 404 ! and side chains.
 405 !
 406 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 407
 408       if (ipot.lt.6) then
 409        if(wscp.gt.0d0) then
 410         call escp(evdw2,evdw2_14)
 411        else
 412         evdw2=0
 413         evdw2_14=0
 414        endif
 415       else
 416 !        write (iout,*) "Soft-sphere SCP potential"
 417         call escp_soft_sphere(evdw2,evdw2_14)
 418       endif
 419 !       write(iout,*) "in etotal before ebond",ipot
 420
 421 !
 422 ! Calculate the bond-stretching energy
 423 !
 424       call ebond(estr)
 425        print *,"EBOND",estr
 426 !       write(iout,*) "in etotal afer ebond",ipot
 427
 428 !
 429 ! Calculate the disulfide-bridge and other energy and the contributions
 430 ! from other distance constraints.
 431 !      print *,'Calling EHPB'
 432       call edis(ehpb)
 433 !elwrite(iout,*) "in etotal afer edis",ipot
 434 !      print *,'EHPB exitted succesfully.'
 435 !
 436 ! Calculate the virtual-bond-angle energy.
 437 !
 438       if (wang.gt.0d0) then
 439         call ebend(ebe,ethetacnstr)
 440       else
 441         ebe=0
 442       endif
 443 !      print *,"Processor",myrank," computed UB"
 444 !
 445 ! Calculate the SC local energy.
 446 !
 447       call esc(escloc)
 448 !elwrite(iout,*) "in etotal afer esc",ipot
 449 !      print *,"Processor",myrank," computed USC"
 450 !
 451 ! Calculate the virtual-bond torsional energy.
 452 !
 453 !d    print *,'nterm=',nterm
 454       if (wtor.gt.0) then
 455        call etor(etors,edihcnstr)
 456       else
 457        etors=0
 458        edihcnstr=0
 459       endif
 460 !      print *,"Processor",myrank," computed Utor"
 461 !
 462 ! 6/23/01 Calculate double-torsional energy
 463 !
 464 !elwrite(iout,*) "in etotal",ipot
 465       if (wtor_d.gt.0) then
 466        call etor_d(etors_d)
 467       else
 468        etors_d=0
 469       endif
 470 !      print *,"Processor",myrank," computed Utord"
 471 !
 472 ! 21/5/07 Calculate local sicdechain correlation energy
 473 !
 474       if (wsccor.gt.0.0d0) then
 475         call eback_sc_corr(esccor)
 476       else
 477         esccor=0.0d0
 478       endif
 479 !      print *,"Processor",myrank," computed Usccorr"
 480 !
 481 ! 12/1/95 Multi-body terms
 482 !
 483       n_corr=0
 484       n_corr1=0
 485       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 486           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 487          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 488 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 489 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 490       else
 491          ecorr=0.0d0
 492          ecorr5=0.0d0
 493          ecorr6=0.0d0
 494          eturn6=0.0d0
 495       endif
 496 !elwrite(iout,*) "in etotal",ipot
 497       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 498          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 499 !d         write (iout,*) "multibody_hb ecorr",ecorr
 500       endif
 501 !elwrite(iout,*) "afeter  multibody hb"
 502
 503 !      print *,"Processor",myrank," computed Ucorr"
 504 !
 505 ! If performing constraint dynamics, call the constraint energy
 506 !  after the equilibration time
 507       if(usampl.and.totT.gt.eq_time) then
 508 !elwrite(iout,*) "afeter  multibody hb"
 509          call EconstrQ
 510 !elwrite(iout,*) "afeter  multibody hb"
 511          call Econstr_back
 512 !elwrite(iout,*) "afeter  multibody hb"
 513       else
 514          Uconst=0.0d0
 515          Uconst_back=0.0d0
 516       endif
 517       call flush(iout)
 518 !         write(iout,*) "after Econstr"
 519
 520       if (wliptran.gt.0) then
 521 !        print *,"PRZED WYWOLANIEM"
 522         call Eliptransfer(eliptran)
 523       else
 524        eliptran=0.0d0
 525       endif
 526       if (fg_rank.eq.0) then
 527       if (AFMlog.gt.0) then
 528         call AFMforce(Eafmforce)
 529       else if (selfguide.gt.0) then
 530         call AFMvel(Eafmforce)
 531       endif
 532       endif
 533       if (tubemode.eq.1) then
 534        call calctube(etube)
 535       else if (tubemode.eq.2) then
 536        call calctube2(etube)
 537       elseif (tubemode.eq.3) then
 538        call calcnano(etube)
 539       else
 540        etube=0.0d0
 541       endif
 542
 543 #ifdef TIMING
 544       time_enecalc=time_enecalc+MPI_Wtime()-time00
 545 #endif
 546 !      print *,"Processor",myrank," computed Uconstr"
 547 #ifdef TIMING
 548       time00=MPI_Wtime()
 549 #endif
 550 !
 551 ! Sum the energies
 552 !
 553       energia(1)=evdw
 554 #ifdef SCP14
 555       energia(2)=evdw2-evdw2_14
 556       energia(18)=evdw2_14
 557 #else
 558       energia(2)=evdw2
 559       energia(18)=0.0d0
 560 #endif
 561 #ifdef SPLITELE
 562       energia(3)=ees
 563       energia(16)=evdw1
 564 #else
 565       energia(3)=ees+evdw1
 566       energia(16)=0.0d0
 567 #endif
 568       energia(4)=ecorr
 569       energia(5)=ecorr5
 570       energia(6)=ecorr6
 571       energia(7)=eel_loc
 572       energia(8)=eello_turn3
 573       energia(9)=eello_turn4
 574       energia(10)=eturn6
 575       energia(11)=ebe
 576       energia(12)=escloc
 577       energia(13)=etors
 578       energia(14)=etors_d
 579       energia(15)=ehpb
 580       energia(19)=edihcnstr
 581       energia(17)=estr
 582       energia(20)=Uconst+Uconst_back
 583       energia(21)=esccor
 584       energia(22)=eliptran
 585       energia(23)=Eafmforce
 586       energia(24)=ethetacnstr
 587       energia(25)=etube
 588 !    Here are the energies showed per procesor if the are more processors
 589 !    per molecule then we sum it up in sum_energy subroutine
 590 !      print *," Processor",myrank," calls SUM_ENERGY"
 591       call sum_energy(energia,.true.)
 592       if (dyn_ss) call dyn_set_nss
 593 !      print *," Processor",myrank," left SUM_ENERGY"
 594 #ifdef TIMING
 595       time_sumene=time_sumene+MPI_Wtime()-time00
 596 #endif
 597 !el        call enerprint(energia)
 598 !elwrite(iout,*)"finish etotal"
 599       return
 600       end subroutine etotal
 601 !-----------------------------------------------------------------------------
 602       subroutine sum_energy(energia,reduce)
 603 !      implicit real*8 (a-h,o-z)
 604 !      include 'DIMENSIONS'
 605 #ifndef ISNAN
 606       external proc_proc
 607 #ifdef WINPGI
 608 !MS$ATTRIBUTES C ::  proc_proc
 609 #endif
 610 #endif
 611 #ifdef MPI
 612       include "mpif.h"
 613 #endif
 614 !      include 'COMMON.SETUP'
 615 !      include 'COMMON.IOUNITS'
 616       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 617 !      include 'COMMON.FFIELD'
 618 !      include 'COMMON.DERIV'
 619 !      include 'COMMON.INTERACT'
 620 !      include 'COMMON.SBRIDGE'
 621 !      include 'COMMON.CHAIN'
 622 !      include 'COMMON.VAR'
 623 !      include 'COMMON.CONTROL'
 624 !      include 'COMMON.TIME1'
 625       logical :: reduce
 626       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 627       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 628       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 629         eliptran,etube, Eafmforce,ethetacnstr
 630       integer :: i
 631 #ifdef MPI
 632       integer :: ierr
 633       real(kind=8) :: time00
 634       if (nfgtasks.gt.1 .and. reduce) then
 635
 636 #ifdef DEBUG
 637         write (iout,*) "energies before REDUCE"
 638         call enerprint(energia)
 639         call flush(iout)
 640 #endif
 641         do i=0,n_ene
 642           enebuff(i)=energia(i)
 643         enddo
 644         time00=MPI_Wtime()
 645         call MPI_Barrier(FG_COMM,IERR)
 646         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 647         time00=MPI_Wtime()
 648         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 649           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 650 #ifdef DEBUG
 651         write (iout,*) "energies after REDUCE"
 652         call enerprint(energia)
 653         call flush(iout)
 654 #endif
 655         time_Reduce=time_Reduce+MPI_Wtime()-time00
 656       endif
 657       if (fg_rank.eq.0) then
 658 #endif
 659       evdw=energia(1)
 660 #ifdef SCP14
 661       evdw2=energia(2)+energia(18)
 662       evdw2_14=energia(18)
 663 #else
 664       evdw2=energia(2)
 665 #endif
 666 #ifdef SPLITELE
 667       ees=energia(3)
 668       evdw1=energia(16)
 669 #else
 670       ees=energia(3)
 671       evdw1=0.0d0
 672 #endif
 673       ecorr=energia(4)
 674       ecorr5=energia(5)
 675       ecorr6=energia(6)
 676       eel_loc=energia(7)
 677       eello_turn3=energia(8)
 678       eello_turn4=energia(9)
 679       eturn6=energia(10)
 680       ebe=energia(11)
 681       escloc=energia(12)
 682       etors=energia(13)
 683       etors_d=energia(14)
 684       ehpb=energia(15)
 685       edihcnstr=energia(19)
 686       estr=energia(17)
 687       Uconst=energia(20)
 688       esccor=energia(21)
 689       eliptran=energia(22)
 690       Eafmforce=energia(23)
 691       ethetacnstr=energia(24)
 692       etube=energia(25)
 693 #ifdef SPLITELE
 694       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 695        +wang*ebe+wtor*etors+wscloc*escloc &
 696        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 697        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 698        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 699        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 700        +Eafmforce+ethetacnstr
 701 #else
 702       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 703        +wang*ebe+wtor*etors+wscloc*escloc &
 704        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 705        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 706        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 707        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 708        +Eafmforce+ethetacnstr
 709
 710 #endif
 711       energia(0)=etot
 712 ! detecting NaNQ
 713 #ifdef ISNAN
 714 #ifdef AIX
 715       if (isnan(etot).ne.0) energia(0)=1.0d+99
 716 #else
 717       if (isnan(etot)) energia(0)=1.0d+99
 718 #endif
 719 #else
 720       i=0
 721 #ifdef WINPGI
 722       idumm=proc_proc(etot,i)
 723 #else
 724       call proc_proc(etot,i)
 725 #endif
 726       if(i.eq.1)energia(0)=1.0d+99
 727 #endif
 728 #ifdef MPI
 729       endif
 730 #endif
 731 !      call enerprint(energia)
 732       call flush(iout)
 733       return
 734       end subroutine sum_energy
 735 !-----------------------------------------------------------------------------
 736       subroutine rescale_weights(t_bath)
 737 !      implicit real*8 (a-h,o-z)
 738 #ifdef MPI
 739       include 'mpif.h'
 740 #endif
 741 !      include 'DIMENSIONS'
 742 !      include 'COMMON.IOUNITS'
 743 !      include 'COMMON.FFIELD'
 744 !      include 'COMMON.SBRIDGE'
 745       real(kind=8) :: kfac=2.4d0
 746       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 747 !el local variables
 748       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 749       real(kind=8) :: T0=3.0d2
 750       integer :: ierror
 751 !      facT=temp0/t_bath
 752 !      facT=2*temp0/(t_bath+temp0)
 753       if (rescale_mode.eq.0) then
 754         facT(1)=1.0d0
 755         facT(2)=1.0d0
 756         facT(3)=1.0d0
 757         facT(4)=1.0d0
 758         facT(5)=1.0d0
 759         facT(6)=1.0d0
 760       else if (rescale_mode.eq.1) then
 761         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 762         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 763         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 764         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 765         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 766 #ifdef WHAM_RUN
 767 !#if defined(WHAM_RUN) || defined(CLUSTER)
 768 #if defined(FUNCTH)
 769 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 770         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 771 #elif defined(FUNCT)
 772         facT(6)=t_bath/T0
 773 #else
 774         facT(6)=1.0d0
 775 #endif
 776 #endif
 777       else if (rescale_mode.eq.2) then
 778         x=t_bath/temp0
 779         x2=x*x
 780         x3=x2*x
 781         x4=x3*x
 782         x5=x4*x
 783         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 784         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 785         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 786         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 787         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 788 #ifdef WHAM_RUN
 789 !#if defined(WHAM_RUN) || defined(CLUSTER)
 790 #if defined(FUNCTH)
 791         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 792 #elif defined(FUNCT)
 793         facT(6)=t_bath/T0
 794 #else
 795         facT(6)=1.0d0
 796 #endif
 797 #endif
 798       else
 799         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 800         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 801 #ifdef MPI
 802        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 803 #endif
 804        stop 555
 805       endif
 806       welec=weights(3)*fact(1)
 807       wcorr=weights(4)*fact(3)
 808       wcorr5=weights(5)*fact(4)
 809       wcorr6=weights(6)*fact(5)
 810       wel_loc=weights(7)*fact(2)
 811       wturn3=weights(8)*fact(2)
 812       wturn4=weights(9)*fact(3)
 813       wturn6=weights(10)*fact(5)
 814       wtor=weights(13)*fact(1)
 815       wtor_d=weights(14)*fact(2)
 816       wsccor=weights(21)*fact(1)
 817
 818       return
 819       end subroutine rescale_weights
 820 !-----------------------------------------------------------------------------
 821       subroutine enerprint(energia)
 822 !      implicit real*8 (a-h,o-z)
 823 !      include 'DIMENSIONS'
 824 !      include 'COMMON.IOUNITS'
 825 !      include 'COMMON.FFIELD'
 826 !      include 'COMMON.SBRIDGE'
 827 !      include 'COMMON.MD'
 828       real(kind=8) :: energia(0:n_ene)
 829 !el local variables
 830       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 831       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 832       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
 833        etube,ethetacnstr,Eafmforce
 834
 835       etot=energia(0)
 836       evdw=energia(1)
 837       evdw2=energia(2)
 838 #ifdef SCP14
 839       evdw2=energia(2)+energia(18)
 840 #else
 841       evdw2=energia(2)
 842 #endif
 843       ees=energia(3)
 844 #ifdef SPLITELE
 845       evdw1=energia(16)
 846 #endif
 847       ecorr=energia(4)
 848       ecorr5=energia(5)
 849       ecorr6=energia(6)
 850       eel_loc=energia(7)
 851       eello_turn3=energia(8)
 852       eello_turn4=energia(9)
 853       eello_turn6=energia(10)
 854       ebe=energia(11)
 855       escloc=energia(12)
 856       etors=energia(13)
 857       etors_d=energia(14)
 858       ehpb=energia(15)
 859       edihcnstr=energia(19)
 860       estr=energia(17)
 861       Uconst=energia(20)
 862       esccor=energia(21)
 863       eliptran=energia(22)
 864       Eafmforce=energia(23)
 865       ethetacnstr=energia(24)
 866       etube=energia(25)
 867 #ifdef SPLITELE
 868       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
 869         estr,wbond,ebe,wang,&
 870         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 871         ecorr,wcorr,&
 872         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 873         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
 874         edihcnstr,ethetacnstr,ebr*nss,&
 875         Uconst,eliptran,wliptran,Eafmforce,etube,wtube,etot
 876    10 format (/'Virtual-chain energies:'// &
 877        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 878        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 879        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 880        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
 881        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 882        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 883        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 884        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 885        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 886        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 887        ' (SS bridges & dist. cnstr.)'/ &
 888        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 889        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 890        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 891        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 892        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 893        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 894        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 895        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 896        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 897        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
 898        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 899        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
 900        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
 901        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
 902        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
 903        'ETOT=  ',1pE16.6,' (total)')
 904 #else
 905       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
 906         estr,wbond,ebe,wang,&
 907         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 908         ecorr,wcorr,&
 909         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 910         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
 911         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
 912         etube,wtube,etot
 913    10 format (/'Virtual-chain energies:'// &
 914        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 915        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 916        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 917        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 918        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 919        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 920        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 921        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 922        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 923        ' (SS bridges & dist. cnstr.)'/ &
 924        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 925        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 926        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 927        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 928        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 929        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 930        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 931        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 932        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 933        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
 934        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 935        'UCONST=',1pE16.6,' (Constraint energy)'/ &
 936        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
 937        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
 938        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
 939        'ETOT=  ',1pE16.6,' (total)')
 940 #endif
 941       return
 942       end subroutine enerprint
 943 !-----------------------------------------------------------------------------
 944       subroutine elj(evdw)
 945 !
 946 ! This subroutine calculates the interaction energy of nonbonded side chains
 947 ! assuming the LJ potential of interaction.
 948 !
 949 !      implicit real*8 (a-h,o-z)
 950 !      include 'DIMENSIONS'
 951       real(kind=8),parameter :: accur=1.0d-10
 952 !      include 'COMMON.GEO'
 953 !      include 'COMMON.VAR'
 954 !      include 'COMMON.LOCAL'
 955 !      include 'COMMON.CHAIN'
 956 !      include 'COMMON.DERIV'
 957 !      include 'COMMON.INTERACT'
 958 !      include 'COMMON.TORSION'
 959 !      include 'COMMON.SBRIDGE'
 960 !      include 'COMMON.NAMES'
 961 !      include 'COMMON.IOUNITS'
 962 !      include 'COMMON.CONTACTS'
 963       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
 964       integer :: num_conti
 965 !el local variables
 966       integer :: i,itypi,iint,j,itypi1,itypj,k
 967       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
 968       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
 969       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
 970
 971 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 972       evdw=0.0D0
 973 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
 974 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
 975 !      allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres)
 976 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))       !(3,maxconts,maxres)
 977
 978       do i=iatsc_s,iatsc_e
 979         itypi=iabs(itype(i,1))
 980         if (itypi.eq.ntyp1) cycle
 981         itypi1=iabs(itype(i+1,1))
 982         xi=c(1,nres+i)
 983         yi=c(2,nres+i)
 984         zi=c(3,nres+i)
 985 ! Change 12/1/95
 986         num_conti=0
 987 !
 988 ! Calculate SC interaction energy.
 989 !
 990         do iint=1,nint_gr(i)
 991 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 992 !d   &                  'iend=',iend(i,iint)
 993           do j=istart(i,iint),iend(i,iint)
 994             itypj=iabs(itype(j,1))
 995             if (itypj.eq.ntyp1) cycle
 996             xj=c(1,nres+j)-xi
 997             yj=c(2,nres+j)-yi
 998             zj=c(3,nres+j)-zi
 999 ! Change 12/1/95 to calculate four-body interactions
1000             rij=xj*xj+yj*yj+zj*zj
1001             rrij=1.0D0/rij
1002 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1003             eps0ij=eps(itypi,itypj)
1004             fac=rrij**expon2
1005             e1=fac*fac*aa_aq(itypi,itypj)
1006             e2=fac*bb_aq(itypi,itypj)
1007             evdwij=e1+e2
1008 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1009 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1010 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1011 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1012 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1013 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1014             evdw=evdw+evdwij
1015 !
1016 ! Calculate the components of the gradient in DC and X
1017 !
1018             fac=-rrij*(e1+evdwij)
1019             gg(1)=xj*fac
1020             gg(2)=yj*fac
1021             gg(3)=zj*fac
1022             do k=1,3
1023               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1024               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1025               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1026               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1027             enddo
1028 !grad            do k=i,j-1
1029 !grad              do l=1,3
1030 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1031 !grad              enddo
1032 !grad            enddo
1033 !
1034 ! 12/1/95, revised on 5/20/97
1035 !
1036 ! Calculate the contact function. The ith column of the array JCONT will
1037 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1038 ! greater than I). The arrays FACONT and GACONT will contain the values of
1039 ! the contact function and its derivative.
1040 !
1041 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1042 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1043 ! Uncomment next line, if the correlation interactions are contact function only
1044             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1045               rij=dsqrt(rij)
1046               sigij=sigma(itypi,itypj)
1047               r0ij=rs0(itypi,itypj)
1048 !
1049 ! Check whether the SC's are not too far to make a contact.
1050 !
1051               rcut=1.5d0*r0ij
1052               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1053 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1054 !
1055               if (fcont.gt.0.0D0) then
1056 ! If the SC-SC distance if close to sigma, apply spline.
1057 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1058 !Adam &             fcont1,fprimcont1)
1059 !Adam           fcont1=1.0d0-fcont1
1060 !Adam           if (fcont1.gt.0.0d0) then
1061 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1062 !Adam             fcont=fcont*fcont1
1063 !Adam           endif
1064 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1065 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1066 !ga             do k=1,3
1067 !ga               gg(k)=gg(k)*eps0ij
1068 !ga             enddo
1069 !ga             eps0ij=-evdwij*eps0ij
1070 ! Uncomment for AL's type of SC correlation interactions.
1071 !adam           eps0ij=-evdwij
1072                 num_conti=num_conti+1
1073                 jcont(num_conti,i)=j
1074                 facont(num_conti,i)=fcont*eps0ij
1075                 fprimcont=eps0ij*fprimcont/rij
1076                 fcont=expon*fcont
1077 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1078 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1079 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1080 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1081                 gacont(1,num_conti,i)=-fprimcont*xj
1082                 gacont(2,num_conti,i)=-fprimcont*yj
1083                 gacont(3,num_conti,i)=-fprimcont*zj
1084 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1085 !d              write (iout,'(2i3,3f10.5)')
1086 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1087               endif
1088             endif
1089           enddo      ! j
1090         enddo        ! iint
1091 ! Change 12/1/95
1092         num_cont(i)=num_conti
1093       enddo          ! i
1094       do i=1,nct
1095         do j=1,3
1096           gvdwc(j,i)=expon*gvdwc(j,i)
1097           gvdwx(j,i)=expon*gvdwx(j,i)
1098         enddo
1099       enddo
1100 !******************************************************************************
1101 !
1102 !                              N O T E !!!
1103 !
1104 ! To save time, the factor of EXPON has been extracted from ALL components
1105 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1106 ! use!
1107 !
1108 !******************************************************************************
1109       return
1110       end subroutine elj
1111 !-----------------------------------------------------------------------------
1112       subroutine eljk(evdw)
1113 !
1114 ! This subroutine calculates the interaction energy of nonbonded side chains
1115 ! assuming the LJK potential of interaction.
1116 !
1117 !      implicit real*8 (a-h,o-z)
1118 !      include 'DIMENSIONS'
1119 !      include 'COMMON.GEO'
1120 !      include 'COMMON.VAR'
1121 !      include 'COMMON.LOCAL'
1122 !      include 'COMMON.CHAIN'
1123 !      include 'COMMON.DERIV'
1124 !      include 'COMMON.INTERACT'
1125 !      include 'COMMON.IOUNITS'
1126 !      include 'COMMON.NAMES'
1127       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1128       logical :: scheck
1129 !el local variables
1130       integer :: i,iint,j,itypi,itypi1,k,itypj
1131       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1132       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1133
1134 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1135       evdw=0.0D0
1136       do i=iatsc_s,iatsc_e
1137         itypi=iabs(itype(i,1))
1138         if (itypi.eq.ntyp1) cycle
1139         itypi1=iabs(itype(i+1,1))
1140         xi=c(1,nres+i)
1141         yi=c(2,nres+i)
1142         zi=c(3,nres+i)
1143 !
1144 ! Calculate SC interaction energy.
1145 !
1146         do iint=1,nint_gr(i)
1147           do j=istart(i,iint),iend(i,iint)
1148             itypj=iabs(itype(j,1))
1149             if (itypj.eq.ntyp1) cycle
1150             xj=c(1,nres+j)-xi
1151             yj=c(2,nres+j)-yi
1152             zj=c(3,nres+j)-zi
1153             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1154             fac_augm=rrij**expon
1155             e_augm=augm(itypi,itypj)*fac_augm
1156             r_inv_ij=dsqrt(rrij)
1157             rij=1.0D0/r_inv_ij
1158             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1159             fac=r_shift_inv**expon
1160             e1=fac*fac*aa_aq(itypi,itypj)
1161             e2=fac*bb_aq(itypi,itypj)
1162             evdwij=e_augm+e1+e2
1163 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1164 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1165 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1166 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1167 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1168 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1169 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1170             evdw=evdw+evdwij
1171 !
1172 ! Calculate the components of the gradient in DC and X
1173 !
1174             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1175             gg(1)=xj*fac
1176             gg(2)=yj*fac
1177             gg(3)=zj*fac
1178             do k=1,3
1179               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1180               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1181               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1182               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1183             enddo
1184 !grad            do k=i,j-1
1185 !grad              do l=1,3
1186 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1187 !grad              enddo
1188 !grad            enddo
1189           enddo      ! j
1190         enddo        ! iint
1191       enddo          ! i
1192       do i=1,nct
1193         do j=1,3
1194           gvdwc(j,i)=expon*gvdwc(j,i)
1195           gvdwx(j,i)=expon*gvdwx(j,i)
1196         enddo
1197       enddo
1198       return
1199       end subroutine eljk
1200 !-----------------------------------------------------------------------------
1201       subroutine ebp(evdw)
1202 !
1203 ! This subroutine calculates the interaction energy of nonbonded side chains
1204 ! assuming the Berne-Pechukas potential of interaction.
1205 !
1206       use comm_srutu
1207       use calc_data
1208 !      implicit real*8 (a-h,o-z)
1209 !      include 'DIMENSIONS'
1210 !      include 'COMMON.GEO'
1211 !      include 'COMMON.VAR'
1212 !      include 'COMMON.LOCAL'
1213 !      include 'COMMON.CHAIN'
1214 !      include 'COMMON.DERIV'
1215 !      include 'COMMON.NAMES'
1216 !      include 'COMMON.INTERACT'
1217 !      include 'COMMON.IOUNITS'
1218 !      include 'COMMON.CALC'
1219       use comm_srutu
1220 !el      integer :: icall
1221 !el      common /srutu/ icall
1222 !     double precision rrsave(maxdim)
1223       logical :: lprn
1224 !el local variables
1225       integer :: iint,itypi,itypi1,itypj
1226       real(kind=8) :: rrij,xi,yi,zi
1227       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1228
1229 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1230       evdw=0.0D0
1231 !     if (icall.eq.0) then
1232 !       lprn=.true.
1233 !     else
1234         lprn=.false.
1235 !     endif
1236 !el      ind=0
1237       do i=iatsc_s,iatsc_e
1238         itypi=iabs(itype(i,1))
1239         if (itypi.eq.ntyp1) cycle
1240         itypi1=iabs(itype(i+1,1))
1241         xi=c(1,nres+i)
1242         yi=c(2,nres+i)
1243         zi=c(3,nres+i)
1244         dxi=dc_norm(1,nres+i)
1245         dyi=dc_norm(2,nres+i)
1246         dzi=dc_norm(3,nres+i)
1247 !        dsci_inv=dsc_inv(itypi)
1248         dsci_inv=vbld_inv(i+nres)
1249 !
1250 ! Calculate SC interaction energy.
1251 !
1252         do iint=1,nint_gr(i)
1253           do j=istart(i,iint),iend(i,iint)
1254 !el            ind=ind+1
1255             itypj=iabs(itype(j,1))
1256             if (itypj.eq.ntyp1) cycle
1257 !            dscj_inv=dsc_inv(itypj)
1258             dscj_inv=vbld_inv(j+nres)
1259             chi1=chi(itypi,itypj)
1260             chi2=chi(itypj,itypi)
1261             chi12=chi1*chi2
1262             chip1=chip(itypi)
1263             chip2=chip(itypj)
1264             chip12=chip1*chip2
1265             alf1=alp(itypi)
1266             alf2=alp(itypj)
1267             alf12=0.5D0*(alf1+alf2)
1268 ! For diagnostics only!!!
1269 !           chi1=0.0D0
1270 !           chi2=0.0D0
1271 !           chi12=0.0D0
1272 !           chip1=0.0D0
1273 !           chip2=0.0D0
1274 !           chip12=0.0D0
1275 !           alf1=0.0D0
1276 !           alf2=0.0D0
1277 !           alf12=0.0D0
1278             xj=c(1,nres+j)-xi
1279             yj=c(2,nres+j)-yi
1280             zj=c(3,nres+j)-zi
1281             dxj=dc_norm(1,nres+j)
1282             dyj=dc_norm(2,nres+j)
1283             dzj=dc_norm(3,nres+j)
1284             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1285 !d          if (icall.eq.0) then
1286 !d            rrsave(ind)=rrij
1287 !d          else
1288 !d            rrij=rrsave(ind)
1289 !d          endif
1290             rij=dsqrt(rrij)
1291 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1292             call sc_angular
1293 ! Calculate whole angle-dependent part of epsilon and contributions
1294 ! to its derivatives
1295             fac=(rrij*sigsq)**expon2
1296             e1=fac*fac*aa_aq(itypi,itypj)
1297             e2=fac*bb_aq(itypi,itypj)
1298             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1299             eps2der=evdwij*eps3rt
1300             eps3der=evdwij*eps2rt
1301             evdwij=evdwij*eps2rt*eps3rt
1302             evdw=evdw+evdwij
1303             if (lprn) then
1304             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1305             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1306 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1307 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1308 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1309 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1310 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1311 !d     &        evdwij
1312             endif
1313 ! Calculate gradient components.
1314             e1=e1*eps1*eps2rt**2*eps3rt**2
1315             fac=-expon*(e1+evdwij)
1316             sigder=fac/sigsq
1317             fac=rrij*fac
1318 ! Calculate radial part of the gradient
1319             gg(1)=xj*fac
1320             gg(2)=yj*fac
1321             gg(3)=zj*fac
1322 ! Calculate the angular part of the gradient and sum add the contributions
1323 ! to the appropriate components of the Cartesian gradient.
1324             call sc_grad
1325           enddo      ! j
1326         enddo        ! iint
1327       enddo          ! i
1328 !     stop
1329       return
1330       end subroutine ebp
1331 !-----------------------------------------------------------------------------
1332       subroutine egb(evdw)
1333 !
1334 ! This subroutine calculates the interaction energy of nonbonded side chains
1335 ! assuming the Gay-Berne potential of interaction.
1336 !
1337       use calc_data
1338 !      implicit real*8 (a-h,o-z)
1339 !      include 'DIMENSIONS'
1340 !      include 'COMMON.GEO'
1341 !      include 'COMMON.VAR'
1342 !      include 'COMMON.LOCAL'
1343 !      include 'COMMON.CHAIN'
1344 !      include 'COMMON.DERIV'
1345 !      include 'COMMON.NAMES'
1346 !      include 'COMMON.INTERACT'
1347 !      include 'COMMON.IOUNITS'
1348 !      include 'COMMON.CALC'
1349 !      include 'COMMON.CONTROL'
1350 !      include 'COMMON.SBRIDGE'
1351       logical :: lprn
1352 !el local variables
1353       integer :: iint,itypi,itypi1,itypj,subchap
1354       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1355       real(kind=8) :: evdw,sig0ij
1356       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1357                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1358                     sslipi,sslipj,faclip
1359       integer :: ii
1360       real(kind=8) :: fracinbuf
1361
1362 !cccc      energy_dec=.false.
1363 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1364       evdw=0.0D0
1365       lprn=.false.
1366 !     if (icall.eq.0) lprn=.false.
1367 !el      ind=0
1368       do i=iatsc_s,iatsc_e
1369 !C        print *,"I am in EVDW",i
1370         itypi=iabs(itype(i,1))
1371 !        if (i.ne.47) cycle
1372         if (itypi.eq.ntyp1) cycle
1373         itypi1=iabs(itype(i+1,1))
1374         xi=c(1,nres+i)
1375         yi=c(2,nres+i)
1376         zi=c(3,nres+i)
1377           xi=dmod(xi,boxxsize)
1378           if (xi.lt.0) xi=xi+boxxsize
1379           yi=dmod(yi,boxysize)
1380           if (yi.lt.0) yi=yi+boxysize
1381           zi=dmod(zi,boxzsize)
1382           if (zi.lt.0) zi=zi+boxzsize
1383
1384        if ((zi.gt.bordlipbot)  &
1385         .and.(zi.lt.bordliptop)) then
1386 !C the energy transfer exist
1387         if (zi.lt.buflipbot) then
1388 !C what fraction I am in
1389          fracinbuf=1.0d0-  &
1390               ((zi-bordlipbot)/lipbufthick)
1391 !C lipbufthick is thickenes of lipid buffore
1392          sslipi=sscalelip(fracinbuf)
1393          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1394         elseif (zi.gt.bufliptop) then
1395          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1396          sslipi=sscalelip(fracinbuf)
1397          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1398         else
1399          sslipi=1.0d0
1400          ssgradlipi=0.0
1401         endif
1402        else
1403          sslipi=0.0d0
1404          ssgradlipi=0.0
1405        endif
1406 !       print *, sslipi,ssgradlipi
1407         dxi=dc_norm(1,nres+i)
1408         dyi=dc_norm(2,nres+i)
1409         dzi=dc_norm(3,nres+i)
1410 !        dsci_inv=dsc_inv(itypi)
1411         dsci_inv=vbld_inv(i+nres)
1412 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1413 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1414 !
1415 ! Calculate SC interaction energy.
1416 !
1417         do iint=1,nint_gr(i)
1418           do j=istart(i,iint),iend(i,iint)
1419             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1420               call dyn_ssbond_ene(i,j,evdwij)
1421               evdw=evdw+evdwij
1422               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1423                               'evdw',i,j,evdwij,' ss'
1424 !              if (energy_dec) write (iout,*) &
1425 !                              'evdw',i,j,evdwij,' ss'
1426              do k=j+1,iend(i,iint)
1427 !C search over all next residues
1428               if (dyn_ss_mask(k)) then
1429 !C check if they are cysteins
1430 !C              write(iout,*) 'k=',k
1431
1432 !c              write(iout,*) "PRZED TRI", evdwij
1433 !               evdwij_przed_tri=evdwij
1434               call triple_ssbond_ene(i,j,k,evdwij)
1435 !c               if(evdwij_przed_tri.ne.evdwij) then
1436 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1437 !c               endif
1438
1439 !c              write(iout,*) "PO TRI", evdwij
1440 !C call the energy function that removes the artifical triple disulfide
1441 !C bond the soubroutine is located in ssMD.F
1442               evdw=evdw+evdwij
1443               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1444                             'evdw',i,j,evdwij,'tss'
1445               endif!dyn_ss_mask(k)
1446              enddo! k
1447             ELSE
1448 !el            ind=ind+1
1449             itypj=iabs(itype(j,1))
1450             if (itypj.eq.ntyp1) cycle
1451 !             if (j.ne.78) cycle
1452 !            dscj_inv=dsc_inv(itypj)
1453             dscj_inv=vbld_inv(j+nres)
1454 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1455 !              1.0d0/vbld(j+nres) !d
1456 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1457             sig0ij=sigma(itypi,itypj)
1458             chi1=chi(itypi,itypj)
1459             chi2=chi(itypj,itypi)
1460             chi12=chi1*chi2
1461             chip1=chip(itypi)
1462             chip2=chip(itypj)
1463             chip12=chip1*chip2
1464             alf1=alp(itypi)
1465             alf2=alp(itypj)
1466             alf12=0.5D0*(alf1+alf2)
1467 ! For diagnostics only!!!
1468 !           chi1=0.0D0
1469 !           chi2=0.0D0
1470 !           chi12=0.0D0
1471 !           chip1=0.0D0
1472 !           chip2=0.0D0
1473 !           chip12=0.0D0
1474 !           alf1=0.0D0
1475 !           alf2=0.0D0
1476 !           alf12=0.0D0
1477            xj=c(1,nres+j)
1478            yj=c(2,nres+j)
1479            zj=c(3,nres+j)
1480           xj=dmod(xj,boxxsize)
1481           if (xj.lt.0) xj=xj+boxxsize
1482           yj=dmod(yj,boxysize)
1483           if (yj.lt.0) yj=yj+boxysize
1484           zj=dmod(zj,boxzsize)
1485           if (zj.lt.0) zj=zj+boxzsize
1486 !          print *,"tu",xi,yi,zi,xj,yj,zj
1487 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1488 ! this fragment set correct epsilon for lipid phase
1489        if ((zj.gt.bordlipbot)  &
1490        .and.(zj.lt.bordliptop)) then
1491 !C the energy transfer exist
1492         if (zj.lt.buflipbot) then
1493 !C what fraction I am in
1494          fracinbuf=1.0d0-     &
1495              ((zj-bordlipbot)/lipbufthick)
1496 !C lipbufthick is thickenes of lipid buffore
1497          sslipj=sscalelip(fracinbuf)
1498          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1499         elseif (zj.gt.bufliptop) then
1500          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1501          sslipj=sscalelip(fracinbuf)
1502          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1503         else
1504          sslipj=1.0d0
1505          ssgradlipj=0.0
1506         endif
1507        else
1508          sslipj=0.0d0
1509          ssgradlipj=0.0
1510        endif
1511       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1512        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1513       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1514        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1515 !------------------------------------------------
1516       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1517       xj_safe=xj
1518       yj_safe=yj
1519       zj_safe=zj
1520       subchap=0
1521       do xshift=-1,1
1522       do yshift=-1,1
1523       do zshift=-1,1
1524           xj=xj_safe+xshift*boxxsize
1525           yj=yj_safe+yshift*boxysize
1526           zj=zj_safe+zshift*boxzsize
1527           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1528           if(dist_temp.lt.dist_init) then
1529             dist_init=dist_temp
1530             xj_temp=xj
1531             yj_temp=yj
1532             zj_temp=zj
1533             subchap=1
1534           endif
1535        enddo
1536        enddo
1537        enddo
1538        if (subchap.eq.1) then
1539           xj=xj_temp-xi
1540           yj=yj_temp-yi
1541           zj=zj_temp-zi
1542        else
1543           xj=xj_safe-xi
1544           yj=yj_safe-yi
1545           zj=zj_safe-zi
1546        endif
1547             dxj=dc_norm(1,nres+j)
1548             dyj=dc_norm(2,nres+j)
1549             dzj=dc_norm(3,nres+j)
1550 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1551 !            write (iout,*) "j",j," dc_norm",& !d
1552 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1553 !          write(iout,*)"rrij ",rrij
1554 !          write(iout,*)"xj yj zj ", xj, yj, zj
1555 !          write(iout,*)"xi yi zi ", xi, yi, zi
1556 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1557             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1558             rij=dsqrt(rrij)
1559             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1560             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1561 !            print *,sss_ele_cut,sss_ele_grad,&
1562 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1563             if (sss_ele_cut.le.0.0) cycle
1564 ! Calculate angle-dependent terms of energy and contributions to their
1565 ! derivatives.
1566             call sc_angular
1567             sigsq=1.0D0/sigsq
1568             sig=sig0ij*dsqrt(sigsq)
1569             rij_shift=1.0D0/rij-sig+sig0ij
1570 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1571 !            "sig0ij",sig0ij
1572 ! for diagnostics; uncomment
1573 !            rij_shift=1.2*sig0ij
1574 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1575             if (rij_shift.le.0.0D0) then
1576               evdw=1.0D20
1577 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1578 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1579 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1580               return
1581             endif
1582             sigder=-sig*sigsq
1583 !---------------------------------------------------------------
1584             rij_shift=1.0D0/rij_shift
1585             fac=rij_shift**expon
1586             faclip=fac
1587             e1=fac*fac*aa!(itypi,itypj)
1588             e2=fac*bb!(itypi,itypj)
1589             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1590             eps2der=evdwij*eps3rt
1591             eps3der=evdwij*eps2rt
1592 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1593 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1594 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1595             evdwij=evdwij*eps2rt*eps3rt
1596             evdw=evdw+evdwij*sss_ele_cut
1597             if (lprn) then
1598             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1599             epsi=bb**2/aa!(itypi,itypj)
1600             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1601               restyp(itypi,1),i,restyp(itypj,1),j, &
1602               epsi,sigm,chi1,chi2,chip1,chip2, &
1603               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1604               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1605               evdwij
1606             endif
1607
1608             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1609                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1610 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1611 !            if (energy_dec) write (iout,*) &
1612 !                             'evdw',i,j,evdwij
1613
1614 ! Calculate gradient components.
1615             e1=e1*eps1*eps2rt**2*eps3rt**2
1616             fac=-expon*(e1+evdwij)*rij_shift
1617             sigder=fac*sigder
1618             fac=rij*fac
1619 !            print *,'before fac',fac,rij,evdwij
1620             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1621             /sigma(itypi,itypj)*rij
1622 !            print *,'grad part scale',fac,   &
1623 !             evdwij*sss_ele_grad/sss_ele_cut &
1624 !            /sigma(itypi,itypj)*rij
1625 !            fac=0.0d0
1626 ! Calculate the radial part of the gradient
1627             gg(1)=xj*fac
1628             gg(2)=yj*fac
1629             gg(3)=zj*fac
1630 !C Calculate the radial part of the gradient
1631             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1632        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1633         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1634        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1635             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1636             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1637
1638 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1639 ! Calculate angular part of the gradient.
1640             call sc_grad
1641             ENDIF    ! dyn_ss
1642           enddo      ! j
1643         enddo        ! iint
1644       enddo          ! i
1645 !      write (iout,*) "Number of loop steps in EGB:",ind
1646 !ccc      energy_dec=.false.
1647       return
1648       end subroutine egb
1649 !-----------------------------------------------------------------------------
1650       subroutine egbv(evdw)
1651 !
1652 ! This subroutine calculates the interaction energy of nonbonded side chains
1653 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1654 !
1655       use comm_srutu
1656       use calc_data
1657 !      implicit real*8 (a-h,o-z)
1658 !      include 'DIMENSIONS'
1659 !      include 'COMMON.GEO'
1660 !      include 'COMMON.VAR'
1661 !      include 'COMMON.LOCAL'
1662 !      include 'COMMON.CHAIN'
1663 !      include 'COMMON.DERIV'
1664 !      include 'COMMON.NAMES'
1665 !      include 'COMMON.INTERACT'
1666 !      include 'COMMON.IOUNITS'
1667 !      include 'COMMON.CALC'
1668       use comm_srutu
1669 !el      integer :: icall
1670 !el      common /srutu/ icall
1671       logical :: lprn
1672 !el local variables
1673       integer :: iint,itypi,itypi1,itypj
1674       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1675       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1676
1677 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1678       evdw=0.0D0
1679       lprn=.false.
1680 !     if (icall.eq.0) lprn=.true.
1681 !el      ind=0
1682       do i=iatsc_s,iatsc_e
1683         itypi=iabs(itype(i,1))
1684         if (itypi.eq.ntyp1) cycle
1685         itypi1=iabs(itype(i+1,1))
1686         xi=c(1,nres+i)
1687         yi=c(2,nres+i)
1688         zi=c(3,nres+i)
1689         dxi=dc_norm(1,nres+i)
1690         dyi=dc_norm(2,nres+i)
1691         dzi=dc_norm(3,nres+i)
1692 !        dsci_inv=dsc_inv(itypi)
1693         dsci_inv=vbld_inv(i+nres)
1694 !
1695 ! Calculate SC interaction energy.
1696 !
1697         do iint=1,nint_gr(i)
1698           do j=istart(i,iint),iend(i,iint)
1699 !el            ind=ind+1
1700             itypj=iabs(itype(j,1))
1701             if (itypj.eq.ntyp1) cycle
1702 !            dscj_inv=dsc_inv(itypj)
1703             dscj_inv=vbld_inv(j+nres)
1704             sig0ij=sigma(itypi,itypj)
1705             r0ij=r0(itypi,itypj)
1706             chi1=chi(itypi,itypj)
1707             chi2=chi(itypj,itypi)
1708             chi12=chi1*chi2
1709             chip1=chip(itypi)
1710             chip2=chip(itypj)
1711             chip12=chip1*chip2
1712             alf1=alp(itypi)
1713             alf2=alp(itypj)
1714             alf12=0.5D0*(alf1+alf2)
1715 ! For diagnostics only!!!
1716 !           chi1=0.0D0
1717 !           chi2=0.0D0
1718 !           chi12=0.0D0
1719 !           chip1=0.0D0
1720 !           chip2=0.0D0
1721 !           chip12=0.0D0
1722 !           alf1=0.0D0
1723 !           alf2=0.0D0
1724 !           alf12=0.0D0
1725             xj=c(1,nres+j)-xi
1726             yj=c(2,nres+j)-yi
1727             zj=c(3,nres+j)-zi
1728             dxj=dc_norm(1,nres+j)
1729             dyj=dc_norm(2,nres+j)
1730             dzj=dc_norm(3,nres+j)
1731             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1732             rij=dsqrt(rrij)
1733 ! Calculate angle-dependent terms of energy and contributions to their
1734 ! derivatives.
1735             call sc_angular
1736             sigsq=1.0D0/sigsq
1737             sig=sig0ij*dsqrt(sigsq)
1738             rij_shift=1.0D0/rij-sig+r0ij
1739 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1740             if (rij_shift.le.0.0D0) then
1741               evdw=1.0D20
1742               return
1743             endif
1744             sigder=-sig*sigsq
1745 !---------------------------------------------------------------
1746             rij_shift=1.0D0/rij_shift
1747             fac=rij_shift**expon
1748             e1=fac*fac*aa_aq(itypi,itypj)
1749             e2=fac*bb_aq(itypi,itypj)
1750             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1751             eps2der=evdwij*eps3rt
1752             eps3der=evdwij*eps2rt
1753             fac_augm=rrij**expon
1754             e_augm=augm(itypi,itypj)*fac_augm
1755             evdwij=evdwij*eps2rt*eps3rt
1756             evdw=evdw+evdwij+e_augm
1757             if (lprn) then
1758             sigm=dabs(aa_aq(itypi,itypj)/&
1759             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1760             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1761             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1762               restyp(itypi,1),i,restyp(itypj,1),j,&
1763               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1764               chi1,chi2,chip1,chip2,&
1765               eps1,eps2rt**2,eps3rt**2,&
1766               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1767               evdwij+e_augm
1768             endif
1769 ! Calculate gradient components.
1770             e1=e1*eps1*eps2rt**2*eps3rt**2
1771             fac=-expon*(e1+evdwij)*rij_shift
1772             sigder=fac*sigder
1773             fac=rij*fac-2*expon*rrij*e_augm
1774 ! Calculate the radial part of the gradient
1775             gg(1)=xj*fac
1776             gg(2)=yj*fac
1777             gg(3)=zj*fac
1778 ! Calculate angular part of the gradient.
1779             call sc_grad
1780           enddo      ! j
1781         enddo        ! iint
1782       enddo          ! i
1783       end subroutine egbv
1784 !-----------------------------------------------------------------------------
1785 !el      subroutine sc_angular in module geometry
1786 !-----------------------------------------------------------------------------
1787       subroutine e_softsphere(evdw)
1788 !
1789 ! This subroutine calculates the interaction energy of nonbonded side chains
1790 ! assuming the LJ potential of interaction.
1791 !
1792 !      implicit real*8 (a-h,o-z)
1793 !      include 'DIMENSIONS'
1794       real(kind=8),parameter :: accur=1.0d-10
1795 !      include 'COMMON.GEO'
1796 !      include 'COMMON.VAR'
1797 !      include 'COMMON.LOCAL'
1798 !      include 'COMMON.CHAIN'
1799 !      include 'COMMON.DERIV'
1800 !      include 'COMMON.INTERACT'
1801 !      include 'COMMON.TORSION'
1802 !      include 'COMMON.SBRIDGE'
1803 !      include 'COMMON.NAMES'
1804 !      include 'COMMON.IOUNITS'
1805 !      include 'COMMON.CONTACTS'
1806       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1807 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1808 !el local variables
1809       integer :: i,iint,j,itypi,itypi1,itypj,k
1810       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1811       real(kind=8) :: fac
1812
1813       evdw=0.0D0
1814       do i=iatsc_s,iatsc_e
1815         itypi=iabs(itype(i,1))
1816         if (itypi.eq.ntyp1) cycle
1817         itypi1=iabs(itype(i+1,1))
1818         xi=c(1,nres+i)
1819         yi=c(2,nres+i)
1820         zi=c(3,nres+i)
1821 !
1822 ! Calculate SC interaction energy.
1823 !
1824         do iint=1,nint_gr(i)
1825 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1826 !d   &                  'iend=',iend(i,iint)
1827           do j=istart(i,iint),iend(i,iint)
1828             itypj=iabs(itype(j,1))
1829             if (itypj.eq.ntyp1) cycle
1830             xj=c(1,nres+j)-xi
1831             yj=c(2,nres+j)-yi
1832             zj=c(3,nres+j)-zi
1833             rij=xj*xj+yj*yj+zj*zj
1834 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1835             r0ij=r0(itypi,itypj)
1836             r0ijsq=r0ij*r0ij
1837 !            print *,i,j,r0ij,dsqrt(rij)
1838             if (rij.lt.r0ijsq) then
1839               evdwij=0.25d0*(rij-r0ijsq)**2
1840               fac=rij-r0ijsq
1841             else
1842               evdwij=0.0d0
1843               fac=0.0d0
1844             endif
1845             evdw=evdw+evdwij
1846 !
1847 ! Calculate the components of the gradient in DC and X
1848 !
1849             gg(1)=xj*fac
1850             gg(2)=yj*fac
1851             gg(3)=zj*fac
1852             do k=1,3
1853               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1854               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1855               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1856               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1857             enddo
1858 !grad            do k=i,j-1
1859 !grad              do l=1,3
1860 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1861 !grad              enddo
1862 !grad            enddo
1863           enddo ! j
1864         enddo ! iint
1865       enddo ! i
1866       return
1867       end subroutine e_softsphere
1868 !-----------------------------------------------------------------------------
1869       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1870 !
1871 ! Soft-sphere potential of p-p interaction
1872 !
1873 !      implicit real*8 (a-h,o-z)
1874 !      include 'DIMENSIONS'
1875 !      include 'COMMON.CONTROL'
1876 !      include 'COMMON.IOUNITS'
1877 !      include 'COMMON.GEO'
1878 !      include 'COMMON.VAR'
1879 !      include 'COMMON.LOCAL'
1880 !      include 'COMMON.CHAIN'
1881 !      include 'COMMON.DERIV'
1882 !      include 'COMMON.INTERACT'
1883 !      include 'COMMON.CONTACTS'
1884 !      include 'COMMON.TORSION'
1885 !      include 'COMMON.VECTORS'
1886 !      include 'COMMON.FFIELD'
1887       real(kind=8),dimension(3) :: ggg
1888 !d      write(iout,*) 'In EELEC_soft_sphere'
1889 !el local variables
1890       integer :: i,j,k,num_conti,iteli,itelj
1891       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
1892       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
1893       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
1894
1895       ees=0.0D0
1896       evdw1=0.0D0
1897       eel_loc=0.0d0
1898       eello_turn3=0.0d0
1899       eello_turn4=0.0d0
1900 !el      ind=0
1901       do i=iatel_s,iatel_e
1902         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
1903         dxi=dc(1,i)
1904         dyi=dc(2,i)
1905         dzi=dc(3,i)
1906         xmedi=c(1,i)+0.5d0*dxi
1907         ymedi=c(2,i)+0.5d0*dyi
1908         zmedi=c(3,i)+0.5d0*dzi
1909         num_conti=0
1910 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1911         do j=ielstart(i),ielend(i)
1912           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
1913 !el          ind=ind+1
1914           iteli=itel(i)
1915           itelj=itel(j)
1916           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1917           r0ij=rpp(iteli,itelj)
1918           r0ijsq=r0ij*r0ij
1919           dxj=dc(1,j)
1920           dyj=dc(2,j)
1921           dzj=dc(3,j)
1922           xj=c(1,j)+0.5D0*dxj-xmedi
1923           yj=c(2,j)+0.5D0*dyj-ymedi
1924           zj=c(3,j)+0.5D0*dzj-zmedi
1925           rij=xj*xj+yj*yj+zj*zj
1926           if (rij.lt.r0ijsq) then
1927             evdw1ij=0.25d0*(rij-r0ijsq)**2
1928             fac=rij-r0ijsq
1929           else
1930             evdw1ij=0.0d0
1931             fac=0.0d0
1932           endif
1933           evdw1=evdw1+evdw1ij
1934 !
1935 ! Calculate contributions to the Cartesian gradient.
1936 !
1937           ggg(1)=fac*xj
1938           ggg(2)=fac*yj
1939           ggg(3)=fac*zj
1940           do k=1,3
1941             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1942             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1943           enddo
1944 !
1945 ! Loop over residues i+1 thru j-1.
1946 !
1947 !grad          do k=i+1,j-1
1948 !grad            do l=1,3
1949 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
1950 !grad            enddo
1951 !grad          enddo
1952         enddo ! j
1953       enddo   ! i
1954 !grad      do i=nnt,nct-1
1955 !grad        do k=1,3
1956 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1957 !grad        enddo
1958 !grad        do j=i+1,nct-1
1959 !grad          do k=1,3
1960 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1961 !grad          enddo
1962 !grad        enddo
1963 !grad      enddo
1964       return
1965       end subroutine eelec_soft_sphere
1966 !-----------------------------------------------------------------------------
1967       subroutine vec_and_deriv
1968 !      implicit real*8 (a-h,o-z)
1969 !      include 'DIMENSIONS'
1970 #ifdef MPI
1971       include 'mpif.h'
1972 #endif
1973 !      include 'COMMON.IOUNITS'
1974 !      include 'COMMON.GEO'
1975 !      include 'COMMON.VAR'
1976 !      include 'COMMON.LOCAL'
1977 !      include 'COMMON.CHAIN'
1978 !      include 'COMMON.VECTORS'
1979 !      include 'COMMON.SETUP'
1980 !      include 'COMMON.TIME1'
1981       real(kind=8),dimension(3,3,2) :: uyder,uzder
1982       real(kind=8),dimension(2) :: vbld_inv_temp
1983 ! Compute the local reference systems. For reference system (i), the
1984 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
1985 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1986 !el local variables
1987       integer :: i,j,k,l
1988       real(kind=8) :: facy,fac,costh
1989
1990 #ifdef PARVEC
1991       do i=ivec_start,ivec_end
1992 #else
1993       do i=1,nres-1
1994 #endif
1995           if (i.eq.nres-1) then
1996 ! Case of the last full residue
1997 ! Compute the Z-axis
1998             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1999             costh=dcos(pi-theta(nres))
2000             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2001             do k=1,3
2002               uz(k,i)=fac*uz(k,i)
2003             enddo
2004 ! Compute the derivatives of uz
2005             uzder(1,1,1)= 0.0d0
2006             uzder(2,1,1)=-dc_norm(3,i-1)
2007             uzder(3,1,1)= dc_norm(2,i-1)
2008             uzder(1,2,1)= dc_norm(3,i-1)
2009             uzder(2,2,1)= 0.0d0
2010             uzder(3,2,1)=-dc_norm(1,i-1)
2011             uzder(1,3,1)=-dc_norm(2,i-1)
2012             uzder(2,3,1)= dc_norm(1,i-1)
2013             uzder(3,3,1)= 0.0d0
2014             uzder(1,1,2)= 0.0d0
2015             uzder(2,1,2)= dc_norm(3,i)
2016             uzder(3,1,2)=-dc_norm(2,i)
2017             uzder(1,2,2)=-dc_norm(3,i)
2018             uzder(2,2,2)= 0.0d0
2019             uzder(3,2,2)= dc_norm(1,i)
2020             uzder(1,3,2)= dc_norm(2,i)
2021             uzder(2,3,2)=-dc_norm(1,i)
2022             uzder(3,3,2)= 0.0d0
2023 ! Compute the Y-axis
2024             facy=fac
2025             do k=1,3
2026               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2027             enddo
2028 ! Compute the derivatives of uy
2029             do j=1,3
2030               do k=1,3
2031                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2032                               -dc_norm(k,i)*dc_norm(j,i-1)
2033                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2034               enddo
2035               uyder(j,j,1)=uyder(j,j,1)-costh
2036               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2037             enddo
2038             do j=1,2
2039               do k=1,3
2040                 do l=1,3
2041                   uygrad(l,k,j,i)=uyder(l,k,j)
2042                   uzgrad(l,k,j,i)=uzder(l,k,j)
2043                 enddo
2044               enddo
2045             enddo
2046             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2047             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2048             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2049             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2050           else
2051 ! Other residues
2052 ! Compute the Z-axis
2053             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2054             costh=dcos(pi-theta(i+2))
2055             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2056             do k=1,3
2057               uz(k,i)=fac*uz(k,i)
2058             enddo
2059 ! Compute the derivatives of uz
2060             uzder(1,1,1)= 0.0d0
2061             uzder(2,1,1)=-dc_norm(3,i+1)
2062             uzder(3,1,1)= dc_norm(2,i+1)
2063             uzder(1,2,1)= dc_norm(3,i+1)
2064             uzder(2,2,1)= 0.0d0
2065             uzder(3,2,1)=-dc_norm(1,i+1)
2066             uzder(1,3,1)=-dc_norm(2,i+1)
2067             uzder(2,3,1)= dc_norm(1,i+1)
2068             uzder(3,3,1)= 0.0d0
2069             uzder(1,1,2)= 0.0d0
2070             uzder(2,1,2)= dc_norm(3,i)
2071             uzder(3,1,2)=-dc_norm(2,i)
2072             uzder(1,2,2)=-dc_norm(3,i)
2073             uzder(2,2,2)= 0.0d0
2074             uzder(3,2,2)= dc_norm(1,i)
2075             uzder(1,3,2)= dc_norm(2,i)
2076             uzder(2,3,2)=-dc_norm(1,i)
2077             uzder(3,3,2)= 0.0d0
2078 ! Compute the Y-axis
2079             facy=fac
2080             do k=1,3
2081               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2082             enddo
2083 ! Compute the derivatives of uy
2084             do j=1,3
2085               do k=1,3
2086                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2087                               -dc_norm(k,i)*dc_norm(j,i+1)
2088                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2089               enddo
2090               uyder(j,j,1)=uyder(j,j,1)-costh
2091               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2092             enddo
2093             do j=1,2
2094               do k=1,3
2095                 do l=1,3
2096                   uygrad(l,k,j,i)=uyder(l,k,j)
2097                   uzgrad(l,k,j,i)=uzder(l,k,j)
2098                 enddo
2099               enddo
2100             enddo
2101             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2102             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2103             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2104             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2105           endif
2106       enddo
2107       do i=1,nres-1
2108         vbld_inv_temp(1)=vbld_inv(i+1)
2109         if (i.lt.nres-1) then
2110           vbld_inv_temp(2)=vbld_inv(i+2)
2111           else
2112           vbld_inv_temp(2)=vbld_inv(i)
2113           endif
2114         do j=1,2
2115           do k=1,3
2116             do l=1,3
2117               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2118               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2119             enddo
2120           enddo
2121         enddo
2122       enddo
2123 #if defined(PARVEC) && defined(MPI)
2124       if (nfgtasks1.gt.1) then
2125         time00=MPI_Wtime()
2126 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2127 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2128 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2129         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2130          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2131          FG_COMM1,IERR)
2132         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2133          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2134          FG_COMM1,IERR)
2135         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2136          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2137          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2138         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2139          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2140          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2141         time_gather=time_gather+MPI_Wtime()-time00
2142       endif
2143 !      if (fg_rank.eq.0) then
2144 !        write (iout,*) "Arrays UY and UZ"
2145 !        do i=1,nres-1
2146 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2147 !     &     (uz(k,i),k=1,3)
2148 !        enddo
2149 !      endif
2150 #endif
2151       return
2152       end subroutine vec_and_deriv
2153 !-----------------------------------------------------------------------------
2154       subroutine check_vecgrad
2155 !      implicit real*8 (a-h,o-z)
2156 !      include 'DIMENSIONS'
2157 !      include 'COMMON.IOUNITS'
2158 !      include 'COMMON.GEO'
2159 !      include 'COMMON.VAR'
2160 !      include 'COMMON.LOCAL'
2161 !      include 'COMMON.CHAIN'
2162 !      include 'COMMON.VECTORS'
2163       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt     !(3,3,2,maxres)
2164       real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
2165       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2166       real(kind=8),dimension(3) :: erij
2167       real(kind=8) :: delta=1.0d-7
2168 !el local variables
2169       integer :: i,j,k,l
2170
2171       call vec_and_deriv
2172 !d      do i=1,nres
2173 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2174 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2175 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2176 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2177 !d     &     (dc_norm(if90,i),if90=1,3)
2178 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2179 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2180 !d          write(iout,'(a)')
2181 !d      enddo
2182       do i=1,nres
2183         do j=1,2
2184           do k=1,3
2185             do l=1,3
2186               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2187               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2188             enddo
2189           enddo
2190         enddo
2191       enddo
2192       call vec_and_deriv
2193       do i=1,nres
2194         do j=1,3
2195           uyt(j,i)=uy(j,i)
2196           uzt(j,i)=uz(j,i)
2197         enddo
2198       enddo
2199       do i=1,nres
2200 !d        write (iout,*) 'i=',i
2201         do k=1,3
2202           erij(k)=dc_norm(k,i)
2203         enddo
2204         do j=1,3
2205           do k=1,3
2206             dc_norm(k,i)=erij(k)
2207           enddo
2208           dc_norm(j,i)=dc_norm(j,i)+delta
2209 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2210 !          do k=1,3
2211 !            dc_norm(k,i)=dc_norm(k,i)/fac
2212 !          enddo
2213 !          write (iout,*) (dc_norm(k,i),k=1,3)
2214 !          write (iout,*) (erij(k),k=1,3)
2215           call vec_and_deriv
2216           do k=1,3
2217             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2218             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2219             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2220             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2221           enddo
2222 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2223 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2224 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2225         enddo
2226         do k=1,3
2227           dc_norm(k,i)=erij(k)
2228         enddo
2229 !d        do k=1,3
2230 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2231 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2232 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2233 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2234 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2235 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2236 !d          write (iout,'(a)')
2237 !d        enddo
2238       enddo
2239       return
2240       end subroutine check_vecgrad
2241 !-----------------------------------------------------------------------------
2242       subroutine set_matrices
2243 !      implicit real*8 (a-h,o-z)
2244 !      include 'DIMENSIONS'
2245 #ifdef MPI
2246       include "mpif.h"
2247 !      include "COMMON.SETUP"
2248       integer :: IERR
2249       integer :: status(MPI_STATUS_SIZE)
2250 #endif
2251 !      include 'COMMON.IOUNITS'
2252 !      include 'COMMON.GEO'
2253 !      include 'COMMON.VAR'
2254 !      include 'COMMON.LOCAL'
2255 !      include 'COMMON.CHAIN'
2256 !      include 'COMMON.DERIV'
2257 !      include 'COMMON.INTERACT'
2258 !      include 'COMMON.CONTACTS'
2259 !      include 'COMMON.TORSION'
2260 !      include 'COMMON.VECTORS'
2261 !      include 'COMMON.FFIELD'
2262       real(kind=8) :: auxvec(2),auxmat(2,2)
2263       integer :: i,iti1,iti,k,l
2264       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2265 !       print *,"in set matrices"
2266 !
2267 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2268 ! to calculate the el-loc multibody terms of various order.
2269 !
2270 !AL el      mu=0.0d0
2271 #ifdef PARMAT
2272       do i=ivec_start+2,ivec_end+2
2273 #else
2274       do i=3,nres+1
2275 #endif
2276 !      print *,i,"i"
2277         if (i .lt. nres+1) then
2278           sin1=dsin(phi(i))
2279           cos1=dcos(phi(i))
2280           sintab(i-2)=sin1
2281           costab(i-2)=cos1
2282           obrot(1,i-2)=cos1
2283           obrot(2,i-2)=sin1
2284           sin2=dsin(2*phi(i))
2285           cos2=dcos(2*phi(i))
2286           sintab2(i-2)=sin2
2287           costab2(i-2)=cos2
2288           obrot2(1,i-2)=cos2
2289           obrot2(2,i-2)=sin2
2290           Ug(1,1,i-2)=-cos1
2291           Ug(1,2,i-2)=-sin1
2292           Ug(2,1,i-2)=-sin1
2293           Ug(2,2,i-2)= cos1
2294           Ug2(1,1,i-2)=-cos2
2295           Ug2(1,2,i-2)=-sin2
2296           Ug2(2,1,i-2)=-sin2
2297           Ug2(2,2,i-2)= cos2
2298         else
2299           costab(i-2)=1.0d0
2300           sintab(i-2)=0.0d0
2301           obrot(1,i-2)=1.0d0
2302           obrot(2,i-2)=0.0d0
2303           obrot2(1,i-2)=0.0d0
2304           obrot2(2,i-2)=0.0d0
2305           Ug(1,1,i-2)=1.0d0
2306           Ug(1,2,i-2)=0.0d0
2307           Ug(2,1,i-2)=0.0d0
2308           Ug(2,2,i-2)=1.0d0
2309           Ug2(1,1,i-2)=0.0d0
2310           Ug2(1,2,i-2)=0.0d0
2311           Ug2(2,1,i-2)=0.0d0
2312           Ug2(2,2,i-2)=0.0d0
2313         endif
2314         if (i .gt. 3 .and. i .lt. nres+1) then
2315           obrot_der(1,i-2)=-sin1
2316           obrot_der(2,i-2)= cos1
2317           Ugder(1,1,i-2)= sin1
2318           Ugder(1,2,i-2)=-cos1
2319           Ugder(2,1,i-2)=-cos1
2320           Ugder(2,2,i-2)=-sin1
2321           dwacos2=cos2+cos2
2322           dwasin2=sin2+sin2
2323           obrot2_der(1,i-2)=-dwasin2
2324           obrot2_der(2,i-2)= dwacos2
2325           Ug2der(1,1,i-2)= dwasin2
2326           Ug2der(1,2,i-2)=-dwacos2
2327           Ug2der(2,1,i-2)=-dwacos2
2328           Ug2der(2,2,i-2)=-dwasin2
2329         else
2330           obrot_der(1,i-2)=0.0d0
2331           obrot_der(2,i-2)=0.0d0
2332           Ugder(1,1,i-2)=0.0d0
2333           Ugder(1,2,i-2)=0.0d0
2334           Ugder(2,1,i-2)=0.0d0
2335           Ugder(2,2,i-2)=0.0d0
2336           obrot2_der(1,i-2)=0.0d0
2337           obrot2_der(2,i-2)=0.0d0
2338           Ug2der(1,1,i-2)=0.0d0
2339           Ug2der(1,2,i-2)=0.0d0
2340           Ug2der(2,1,i-2)=0.0d0
2341           Ug2der(2,2,i-2)=0.0d0
2342         endif
2343 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2344         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2345           iti = itortyp(itype(i-2,1))
2346         else
2347           iti=ntortyp+1
2348         endif
2349 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2350         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2351           iti1 = itortyp(itype(i-1,1))
2352         else
2353           iti1=ntortyp+1
2354         endif
2355 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2356 !d        write (iout,*) '*******i',i,' iti1',iti
2357 !d        write (iout,*) 'b1',b1(:,iti)
2358 !d        write (iout,*) 'b2',b2(:,iti)
2359 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2360 !        if (i .gt. iatel_s+2) then
2361         if (i .gt. nnt+2) then
2362           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2363           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2364           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2365           then
2366           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2367           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2368           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2369           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2370           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2371           endif
2372         else
2373           do k=1,2
2374             Ub2(k,i-2)=0.0d0
2375             Ctobr(k,i-2)=0.0d0
2376             Dtobr2(k,i-2)=0.0d0
2377             do l=1,2
2378               EUg(l,k,i-2)=0.0d0
2379               CUg(l,k,i-2)=0.0d0
2380               DUg(l,k,i-2)=0.0d0
2381               DtUg2(l,k,i-2)=0.0d0
2382             enddo
2383           enddo
2384         endif
2385         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2386         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2387         do k=1,2
2388           muder(k,i-2)=Ub2der(k,i-2)
2389         enddo
2390 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2391         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2392           if (itype(i-1,1).le.ntyp) then
2393             iti1 = itortyp(itype(i-1,1))
2394           else
2395             iti1=ntortyp+1
2396           endif
2397         else
2398           iti1=ntortyp+1
2399         endif
2400         do k=1,2
2401           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2402         enddo
2403 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2404 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2405 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2406 !d        write (iout,*) 'mu1',mu1(:,i-2)
2407 !d        write (iout,*) 'mu2',mu2(:,i-2)
2408         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2409         then
2410         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2411         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2412         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2413         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2414         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2415 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2416         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2417         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2418         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2419         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2420         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2421         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2422         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2423         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2424         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2425         endif
2426       enddo
2427 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2428 ! The order of matrices is from left to right.
2429       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2430       then
2431 !      do i=max0(ivec_start,2),ivec_end
2432       do i=2,nres-1
2433         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2434         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2435         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2436         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2437         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2438         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2439         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2440         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2441       enddo
2442       endif
2443 #if defined(MPI) && defined(PARMAT)
2444 #ifdef DEBUG
2445 !      if (fg_rank.eq.0) then
2446         write (iout,*) "Arrays UG and UGDER before GATHER"
2447         do i=1,nres-1
2448           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2449            ((ug(l,k,i),l=1,2),k=1,2),&
2450            ((ugder(l,k,i),l=1,2),k=1,2)
2451         enddo
2452         write (iout,*) "Arrays UG2 and UG2DER"
2453         do i=1,nres-1
2454           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2455            ((ug2(l,k,i),l=1,2),k=1,2),&
2456            ((ug2der(l,k,i),l=1,2),k=1,2)
2457         enddo
2458         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2459         do i=1,nres-1
2460           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2461            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2462            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2463         enddo
2464         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2465         do i=1,nres-1
2466           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2467            costab(i),sintab(i),costab2(i),sintab2(i)
2468         enddo
2469         write (iout,*) "Array MUDER"
2470         do i=1,nres-1
2471           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2472         enddo
2473 !      endif
2474 #endif
2475       if (nfgtasks.gt.1) then
2476         time00=MPI_Wtime()
2477 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2478 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2479 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2480 #ifdef MATGATHER
2481         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2482          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2483          FG_COMM1,IERR)
2484         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2485          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2486          FG_COMM1,IERR)
2487         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2488          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2489          FG_COMM1,IERR)
2490         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2491          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2492          FG_COMM1,IERR)
2493         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2494          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2495          FG_COMM1,IERR)
2496         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2497          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2498          FG_COMM1,IERR)
2499         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2500          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2501          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2502         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2503          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2504          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2505         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2506          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2507          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2508         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2509          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2510          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2511         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2512         then
2513         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2514          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2515          FG_COMM1,IERR)
2516         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2517          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2518          FG_COMM1,IERR)
2519         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2520          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2521          FG_COMM1,IERR)
2522        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2523          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2524          FG_COMM1,IERR)
2525         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2526          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2527          FG_COMM1,IERR)
2528         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2529          ivec_count(fg_rank1),&
2530          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2531          FG_COMM1,IERR)
2532         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2533          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2534          FG_COMM1,IERR)
2535         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2536          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2537          FG_COMM1,IERR)
2538         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2539          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2540          FG_COMM1,IERR)
2541         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2542          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2543          FG_COMM1,IERR)
2544         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2545          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2546          FG_COMM1,IERR)
2547         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2548          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2549          FG_COMM1,IERR)
2550         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2551          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2552          FG_COMM1,IERR)
2553         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2554          ivec_count(fg_rank1),&
2555          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2556          FG_COMM1,IERR)
2557         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2558          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2559          FG_COMM1,IERR)
2560        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2561          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2562          FG_COMM1,IERR)
2563         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2564          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2565          FG_COMM1,IERR)
2566        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2567          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2568          FG_COMM1,IERR)
2569         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2570          ivec_count(fg_rank1),&
2571          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2572          FG_COMM1,IERR)
2573         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2574          ivec_count(fg_rank1),&
2575          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2576          FG_COMM1,IERR)
2577         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2578          ivec_count(fg_rank1),&
2579          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2580          MPI_MAT2,FG_COMM1,IERR)
2581         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2582          ivec_count(fg_rank1),&
2583          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2584          MPI_MAT2,FG_COMM1,IERR)
2585         endif
2586 #else
2587 ! Passes matrix info through the ring
2588       isend=fg_rank1
2589       irecv=fg_rank1-1
2590       if (irecv.lt.0) irecv=nfgtasks1-1
2591       iprev=irecv
2592       inext=fg_rank1+1
2593       if (inext.ge.nfgtasks1) inext=0
2594       do i=1,nfgtasks1-1
2595 !        write (iout,*) "isend",isend," irecv",irecv
2596 !        call flush(iout)
2597         lensend=lentyp(isend)
2598         lenrecv=lentyp(irecv)
2599 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2600 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2601 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2602 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2603 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2604 !        write (iout,*) "Gather ROTAT1"
2605 !        call flush(iout)
2606 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2607 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2608 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2609 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2610 !        write (iout,*) "Gather ROTAT2"
2611 !        call flush(iout)
2612         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2613          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2614          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2615          iprev,4400+irecv,FG_COMM,status,IERR)
2616 !        write (iout,*) "Gather ROTAT_OLD"
2617 !        call flush(iout)
2618         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2619          MPI_PRECOMP11(lensend),inext,5500+isend,&
2620          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2621          iprev,5500+irecv,FG_COMM,status,IERR)
2622 !        write (iout,*) "Gather PRECOMP11"
2623 !        call flush(iout)
2624         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2625          MPI_PRECOMP12(lensend),inext,6600+isend,&
2626          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2627          iprev,6600+irecv,FG_COMM,status,IERR)
2628 !        write (iout,*) "Gather PRECOMP12"
2629 !        call flush(iout)
2630         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2631         then
2632         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2633          MPI_ROTAT2(lensend),inext,7700+isend,&
2634          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2635          iprev,7700+irecv,FG_COMM,status,IERR)
2636 !        write (iout,*) "Gather PRECOMP21"
2637 !        call flush(iout)
2638         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2639          MPI_PRECOMP22(lensend),inext,8800+isend,&
2640          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2641          iprev,8800+irecv,FG_COMM,status,IERR)
2642 !        write (iout,*) "Gather PRECOMP22"
2643 !        call flush(iout)
2644         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2645          MPI_PRECOMP23(lensend),inext,9900+isend,&
2646          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2647          MPI_PRECOMP23(lenrecv),&
2648          iprev,9900+irecv,FG_COMM,status,IERR)
2649 !        write (iout,*) "Gather PRECOMP23"
2650 !        call flush(iout)
2651         endif
2652         isend=irecv
2653         irecv=irecv-1
2654         if (irecv.lt.0) irecv=nfgtasks1-1
2655       enddo
2656 #endif
2657         time_gather=time_gather+MPI_Wtime()-time00
2658       endif
2659 #ifdef DEBUG
2660 !      if (fg_rank.eq.0) then
2661         write (iout,*) "Arrays UG and UGDER"
2662         do i=1,nres-1
2663           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2664            ((ug(l,k,i),l=1,2),k=1,2),&
2665            ((ugder(l,k,i),l=1,2),k=1,2)
2666         enddo
2667         write (iout,*) "Arrays UG2 and UG2DER"
2668         do i=1,nres-1
2669           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2670            ((ug2(l,k,i),l=1,2),k=1,2),&
2671            ((ug2der(l,k,i),l=1,2),k=1,2)
2672         enddo
2673         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2674         do i=1,nres-1
2675           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2676            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2677            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2678         enddo
2679         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2680         do i=1,nres-1
2681           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2682            costab(i),sintab(i),costab2(i),sintab2(i)
2683         enddo
2684         write (iout,*) "Array MUDER"
2685         do i=1,nres-1
2686           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2687         enddo
2688 !      endif
2689 #endif
2690 #endif
2691 !d      do i=1,nres
2692 !d        iti = itortyp(itype(i,1))
2693 !d        write (iout,*) i
2694 !d        do j=1,2
2695 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2696 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2697 !d        enddo
2698 !d      enddo
2699       return
2700       end subroutine set_matrices
2701 !-----------------------------------------------------------------------------
2702       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2703 !
2704 ! This subroutine calculates the average interaction energy and its gradient
2705 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2706 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2707 ! The potential depends both on the distance of peptide-group centers and on
2708 ! the orientation of the CA-CA virtual bonds.
2709 !
2710       use comm_locel
2711 !      implicit real*8 (a-h,o-z)
2712 #ifdef MPI
2713       include 'mpif.h'
2714 #endif
2715 !      include 'DIMENSIONS'
2716 !      include 'COMMON.CONTROL'
2717 !      include 'COMMON.SETUP'
2718 !      include 'COMMON.IOUNITS'
2719 !      include 'COMMON.GEO'
2720 !      include 'COMMON.VAR'
2721 !      include 'COMMON.LOCAL'
2722 !      include 'COMMON.CHAIN'
2723 !      include 'COMMON.DERIV'
2724 !      include 'COMMON.INTERACT'
2725 !      include 'COMMON.CONTACTS'
2726 !      include 'COMMON.TORSION'
2727 !      include 'COMMON.VECTORS'
2728 !      include 'COMMON.FFIELD'
2729 !      include 'COMMON.TIME1'
2730       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2731       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2732       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2733 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2734       real(kind=8),dimension(4) :: muij
2735 !el      integer :: num_conti,j1,j2
2736 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2737 !el        dz_normi,xmedi,ymedi,zmedi
2738
2739 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2740 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2741 !el          num_conti,j1,j2
2742
2743 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2744 #ifdef MOMENT
2745       real(kind=8) :: scal_el=1.0d0
2746 #else
2747       real(kind=8) :: scal_el=0.5d0
2748 #endif
2749 ! 12/13/98
2750 ! 13-go grudnia roku pamietnego...
2751       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2752                                              0.0d0,1.0d0,0.0d0,&
2753                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2754 !el local variables
2755       integer :: i,k,j
2756       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2757       real(kind=8) :: fac,t_eelecij,fracinbuf
2758
2759
2760 !d      write(iout,*) 'In EELEC'
2761 !        print *,"IN EELEC"
2762 !d      do i=1,nloctyp
2763 !d        write(iout,*) 'Type',i
2764 !d        write(iout,*) 'B1',B1(:,i)
2765 !d        write(iout,*) 'B2',B2(:,i)
2766 !d        write(iout,*) 'CC',CC(:,:,i)
2767 !d        write(iout,*) 'DD',DD(:,:,i)
2768 !d        write(iout,*) 'EE',EE(:,:,i)
2769 !d      enddo
2770 !d      call check_vecgrad
2771 !d      stop
2772 !      ees=0.0d0  !AS
2773 !      evdw1=0.0d0
2774 !      eel_loc=0.0d0
2775 !      eello_turn3=0.0d0
2776 !      eello_turn4=0.0d0
2777       t_eelecij=0.0d0
2778       ees=0.0D0
2779       evdw1=0.0D0
2780       eel_loc=0.0d0
2781       eello_turn3=0.0d0
2782       eello_turn4=0.0d0
2783 !
2784
2785       if (icheckgrad.eq.1) then
2786 !el
2787 !        do i=0,2*nres+2
2788 !          dc_norm(1,i)=0.0d0
2789 !          dc_norm(2,i)=0.0d0
2790 !          dc_norm(3,i)=0.0d0
2791 !        enddo
2792         do i=1,nres-1
2793           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2794           do k=1,3
2795             dc_norm(k,i)=dc(k,i)*fac
2796           enddo
2797 !          write (iout,*) 'i',i,' fac',fac
2798         enddo
2799       endif
2800 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
2801 !        wturn6
2802       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2803           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2804           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2805 !        call vec_and_deriv
2806 #ifdef TIMING
2807         time01=MPI_Wtime()
2808 #endif
2809 !        print *, "before set matrices"
2810         call set_matrices
2811 !        print *, "after set matrices"
2812
2813 #ifdef TIMING
2814         time_mat=time_mat+MPI_Wtime()-time01
2815 #endif
2816       endif
2817 !       print *, "after set matrices"
2818 !d      do i=1,nres-1
2819 !d        write (iout,*) 'i=',i
2820 !d        do k=1,3
2821 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2822 !d        enddo
2823 !d        do k=1,3
2824 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2825 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2826 !d        enddo
2827 !d      enddo
2828       t_eelecij=0.0d0
2829       ees=0.0D0
2830       evdw1=0.0D0
2831       eel_loc=0.0d0
2832       eello_turn3=0.0d0
2833       eello_turn4=0.0d0
2834 !el      ind=0
2835       do i=1,nres
2836         num_cont_hb(i)=0
2837       enddo
2838 !d      print '(a)','Enter EELEC'
2839 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2840 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2841 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2842       do i=1,nres
2843         gel_loc_loc(i)=0.0d0
2844         gcorr_loc(i)=0.0d0
2845       enddo
2846 !
2847 !
2848 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2849 !
2850 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
2851 !
2852
2853
2854 !        print *,"before iturn3 loop"
2855       do i=iturn3_start,iturn3_end
2856         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
2857         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
2858         dxi=dc(1,i)
2859         dyi=dc(2,i)
2860         dzi=dc(3,i)
2861         dx_normi=dc_norm(1,i)
2862         dy_normi=dc_norm(2,i)
2863         dz_normi=dc_norm(3,i)
2864         xmedi=c(1,i)+0.5d0*dxi
2865         ymedi=c(2,i)+0.5d0*dyi
2866         zmedi=c(3,i)+0.5d0*dzi
2867           xmedi=dmod(xmedi,boxxsize)
2868           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2869           ymedi=dmod(ymedi,boxysize)
2870           if (ymedi.lt.0) ymedi=ymedi+boxysize
2871           zmedi=dmod(zmedi,boxzsize)
2872           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2873         num_conti=0
2874        if ((zmedi.gt.bordlipbot) &
2875         .and.(zmedi.lt.bordliptop)) then
2876 !C the energy transfer exist
2877         if (zmedi.lt.buflipbot) then
2878 !C what fraction I am in
2879          fracinbuf=1.0d0- &
2880                ((zmedi-bordlipbot)/lipbufthick)
2881 !C lipbufthick is thickenes of lipid buffore
2882          sslipi=sscalelip(fracinbuf)
2883          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2884         elseif (zmedi.gt.bufliptop) then
2885          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2886          sslipi=sscalelip(fracinbuf)
2887          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2888         else
2889          sslipi=1.0d0
2890          ssgradlipi=0.0
2891         endif
2892        else
2893          sslipi=0.0d0
2894          ssgradlipi=0.0
2895        endif
2896 !       print *,i,sslipi,ssgradlipi
2897        call eelecij(i,i+2,ees,evdw1,eel_loc)
2898         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2899         num_cont_hb(i)=num_conti
2900       enddo
2901       do i=iturn4_start,iturn4_end
2902         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
2903           .or. itype(i+3,1).eq.ntyp1 &
2904           .or. itype(i+4,1).eq.ntyp1) cycle
2905         dxi=dc(1,i)
2906         dyi=dc(2,i)
2907         dzi=dc(3,i)
2908         dx_normi=dc_norm(1,i)
2909         dy_normi=dc_norm(2,i)
2910         dz_normi=dc_norm(3,i)
2911         xmedi=c(1,i)+0.5d0*dxi
2912         ymedi=c(2,i)+0.5d0*dyi
2913         zmedi=c(3,i)+0.5d0*dzi
2914           xmedi=dmod(xmedi,boxxsize)
2915           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2916           ymedi=dmod(ymedi,boxysize)
2917           if (ymedi.lt.0) ymedi=ymedi+boxysize
2918           zmedi=dmod(zmedi,boxzsize)
2919           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2920        if ((zmedi.gt.bordlipbot)  &
2921        .and.(zmedi.lt.bordliptop)) then
2922 !C the energy transfer exist
2923         if (zmedi.lt.buflipbot) then
2924 !C what fraction I am in
2925          fracinbuf=1.0d0- &
2926              ((zmedi-bordlipbot)/lipbufthick)
2927 !C lipbufthick is thickenes of lipid buffore
2928          sslipi=sscalelip(fracinbuf)
2929          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2930         elseif (zmedi.gt.bufliptop) then
2931          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2932          sslipi=sscalelip(fracinbuf)
2933          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2934         else
2935          sslipi=1.0d0
2936          ssgradlipi=0.0
2937         endif
2938        else
2939          sslipi=0.0d0
2940          ssgradlipi=0.0
2941        endif
2942
2943         num_conti=num_cont_hb(i)
2944         call eelecij(i,i+3,ees,evdw1,eel_loc)
2945         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
2946          call eturn4(i,eello_turn4)
2947         num_cont_hb(i)=num_conti
2948       enddo   ! i
2949 !
2950 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2951 !
2952       do i=iatel_s,iatel_e
2953         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2954         dxi=dc(1,i)
2955         dyi=dc(2,i)
2956         dzi=dc(3,i)
2957         dx_normi=dc_norm(1,i)
2958         dy_normi=dc_norm(2,i)
2959         dz_normi=dc_norm(3,i)
2960         xmedi=c(1,i)+0.5d0*dxi
2961         ymedi=c(2,i)+0.5d0*dyi
2962         zmedi=c(3,i)+0.5d0*dzi
2963           xmedi=dmod(xmedi,boxxsize)
2964           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2965           ymedi=dmod(ymedi,boxysize)
2966           if (ymedi.lt.0) ymedi=ymedi+boxysize
2967           zmedi=dmod(zmedi,boxzsize)
2968           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2969        if ((zmedi.gt.bordlipbot)  &
2970         .and.(zmedi.lt.bordliptop)) then
2971 !C the energy transfer exist
2972         if (zmedi.lt.buflipbot) then
2973 !C what fraction I am in
2974          fracinbuf=1.0d0- &
2975              ((zmedi-bordlipbot)/lipbufthick)
2976 !C lipbufthick is thickenes of lipid buffore
2977          sslipi=sscalelip(fracinbuf)
2978          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2979         elseif (zmedi.gt.bufliptop) then
2980          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2981          sslipi=sscalelip(fracinbuf)
2982          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2983         else
2984          sslipi=1.0d0
2985          ssgradlipi=0.0
2986         endif
2987        else
2988          sslipi=0.0d0
2989          ssgradlipi=0.0
2990        endif
2991
2992 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2993         num_conti=num_cont_hb(i)
2994         do j=ielstart(i),ielend(i)
2995 !          write (iout,*) i,j,itype(i,1),itype(j,1)
2996           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
2997           call eelecij(i,j,ees,evdw1,eel_loc)
2998         enddo ! j
2999         num_cont_hb(i)=num_conti
3000       enddo   ! i
3001 !      write (iout,*) "Number of loop steps in EELEC:",ind
3002 !d      do i=1,nres
3003 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3004 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3005 !d      enddo
3006 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3007 !cc      eel_loc=eel_loc+eello_turn3
3008 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3009       return
3010       end subroutine eelec
3011 !-----------------------------------------------------------------------------
3012       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3013
3014       use comm_locel
3015 !      implicit real*8 (a-h,o-z)
3016 !      include 'DIMENSIONS'
3017 #ifdef MPI
3018       include "mpif.h"
3019 #endif
3020 !      include 'COMMON.CONTROL'
3021 !      include 'COMMON.IOUNITS'
3022 !      include 'COMMON.GEO'
3023 !      include 'COMMON.VAR'
3024 !      include 'COMMON.LOCAL'
3025 !      include 'COMMON.CHAIN'
3026 !      include 'COMMON.DERIV'
3027 !      include 'COMMON.INTERACT'
3028 !      include 'COMMON.CONTACTS'
3029 !      include 'COMMON.TORSION'
3030 !      include 'COMMON.VECTORS'
3031 !      include 'COMMON.FFIELD'
3032 !      include 'COMMON.TIME1'
3033       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3034       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3035       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3036 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3037       real(kind=8),dimension(4) :: muij
3038       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3039                     dist_temp, dist_init,rlocshield,fracinbuf
3040       integer xshift,yshift,zshift,ilist,iresshield
3041 !el      integer :: num_conti,j1,j2
3042 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3043 !el        dz_normi,xmedi,ymedi,zmedi
3044
3045 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3046 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3047 !el          num_conti,j1,j2
3048
3049 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3050 #ifdef MOMENT
3051       real(kind=8) :: scal_el=1.0d0
3052 #else
3053       real(kind=8) :: scal_el=0.5d0
3054 #endif
3055 ! 12/13/98
3056 ! 13-go grudnia roku pamietnego...
3057       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3058                                              0.0d0,1.0d0,0.0d0,&
3059                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3060 !      integer :: maxconts=nres/4
3061 !el local variables
3062       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3063       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3064       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3065       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3066                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3067                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3068                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3069                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3070                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3071                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3072                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3073 !      maxconts=nres/4
3074 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3075 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3076
3077 !          time00=MPI_Wtime()
3078 !d      write (iout,*) "eelecij",i,j
3079 !          ind=ind+1
3080           iteli=itel(i)
3081           itelj=itel(j)
3082           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3083           aaa=app(iteli,itelj)
3084           bbb=bpp(iteli,itelj)
3085           ael6i=ael6(iteli,itelj)
3086           ael3i=ael3(iteli,itelj)
3087           dxj=dc(1,j)
3088           dyj=dc(2,j)
3089           dzj=dc(3,j)
3090           dx_normj=dc_norm(1,j)
3091           dy_normj=dc_norm(2,j)
3092           dz_normj=dc_norm(3,j)
3093 !          xj=c(1,j)+0.5D0*dxj-xmedi
3094 !          yj=c(2,j)+0.5D0*dyj-ymedi
3095 !          zj=c(3,j)+0.5D0*dzj-zmedi
3096           xj=c(1,j)+0.5D0*dxj
3097           yj=c(2,j)+0.5D0*dyj
3098           zj=c(3,j)+0.5D0*dzj
3099           xj=mod(xj,boxxsize)
3100           if (xj.lt.0) xj=xj+boxxsize
3101           yj=mod(yj,boxysize)
3102           if (yj.lt.0) yj=yj+boxysize
3103           zj=mod(zj,boxzsize)
3104           if (zj.lt.0) zj=zj+boxzsize
3105        if ((zj.gt.bordlipbot)  &
3106        .and.(zj.lt.bordliptop)) then
3107 !C the energy transfer exist
3108         if (zj.lt.buflipbot) then
3109 !C what fraction I am in
3110          fracinbuf=1.0d0-     &
3111              ((zj-bordlipbot)/lipbufthick)
3112 !C lipbufthick is thickenes of lipid buffore
3113          sslipj=sscalelip(fracinbuf)
3114          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3115         elseif (zj.gt.bufliptop) then
3116          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3117          sslipj=sscalelip(fracinbuf)
3118          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3119         else
3120          sslipj=1.0d0
3121          ssgradlipj=0.0
3122         endif
3123        else
3124          sslipj=0.0d0
3125          ssgradlipj=0.0
3126        endif
3127
3128       isubchap=0
3129       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3130       xj_safe=xj
3131       yj_safe=yj
3132       zj_safe=zj
3133       do xshift=-1,1
3134       do yshift=-1,1
3135       do zshift=-1,1
3136           xj=xj_safe+xshift*boxxsize
3137           yj=yj_safe+yshift*boxysize
3138           zj=zj_safe+zshift*boxzsize
3139           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3140           if(dist_temp.lt.dist_init) then
3141             dist_init=dist_temp
3142             xj_temp=xj
3143             yj_temp=yj
3144             zj_temp=zj
3145             isubchap=1
3146           endif
3147        enddo
3148        enddo
3149        enddo
3150        if (isubchap.eq.1) then
3151 !C          print *,i,j
3152           xj=xj_temp-xmedi
3153           yj=yj_temp-ymedi
3154           zj=zj_temp-zmedi
3155        else
3156           xj=xj_safe-xmedi
3157           yj=yj_safe-ymedi
3158           zj=zj_safe-zmedi
3159        endif
3160
3161           rij=xj*xj+yj*yj+zj*zj
3162           rrmij=1.0D0/rij
3163           rij=dsqrt(rij)
3164 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3165             sss_ele_cut=sscale_ele(rij)
3166             sss_ele_grad=sscagrad_ele(rij)
3167 !             sss_ele_cut=1.0d0
3168 !             sss_ele_grad=0.0d0
3169 !            print *,sss_ele_cut,sss_ele_grad,&
3170 !            (rij),r_cut_ele,rlamb_ele
3171 !            if (sss_ele_cut.le.0.0) go to 128
3172
3173           rmij=1.0D0/rij
3174           r3ij=rrmij*rmij
3175           r6ij=r3ij*r3ij
3176           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3177           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3178           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3179           fac=cosa-3.0D0*cosb*cosg
3180           ev1=aaa*r6ij*r6ij
3181 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3182           if (j.eq.i+2) ev1=scal_el*ev1
3183           ev2=bbb*r6ij
3184           fac3=ael6i*r6ij
3185           fac4=ael3i*r3ij
3186           evdwij=ev1+ev2
3187           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3188           el2=fac4*fac
3189 !          eesij=el1+el2
3190           if (shield_mode.gt.0) then
3191 !C          fac_shield(i)=0.4
3192 !C          fac_shield(j)=0.6
3193           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3194           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3195           eesij=(el1+el2)
3196           ees=ees+eesij*sss_ele_cut
3197 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3198 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3199           else
3200           fac_shield(i)=1.0
3201           fac_shield(j)=1.0
3202           eesij=(el1+el2)
3203           ees=ees+eesij   &
3204             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3205 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3206           endif
3207
3208 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3209           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3210 !          ees=ees+eesij*sss_ele_cut
3211           evdw1=evdw1+evdwij*sss_ele_cut  &
3212            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3213 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3214 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3215 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3216 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3217
3218           if (energy_dec) then
3219 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3220 !                  'evdw1',i,j,evdwij,&
3221 !                  iteli,itelj,aaa,evdw1
3222               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3223               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3224           endif
3225 !
3226 ! Calculate contributions to the Cartesian gradient.
3227 !
3228 #ifdef SPLITELE
3229           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3230               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3231           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3232              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3233           fac1=fac
3234           erij(1)=xj*rmij
3235           erij(2)=yj*rmij
3236           erij(3)=zj*rmij
3237 !
3238 ! Radial derivatives. First process both termini of the fragment (i,j)
3239 !
3240           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3241           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3242           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3243            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3244           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3245             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3246
3247           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3248           (shield_mode.gt.0)) then
3249 !C          print *,i,j
3250           do ilist=1,ishield_list(i)
3251            iresshield=shield_list(ilist,i)
3252            do k=1,3
3253            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3254            *2.0*sss_ele_cut
3255            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3256                    rlocshield &
3257             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3258             *sss_ele_cut
3259             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3260            enddo
3261           enddo
3262           do ilist=1,ishield_list(j)
3263            iresshield=shield_list(ilist,j)
3264            do k=1,3
3265            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3266           *2.0*sss_ele_cut
3267            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3268                    rlocshield &
3269            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3270            *sss_ele_cut
3271            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3272            enddo
3273           enddo
3274           do k=1,3
3275             gshieldc(k,i)=gshieldc(k,i)+ &
3276                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3277            *sss_ele_cut
3278
3279             gshieldc(k,j)=gshieldc(k,j)+ &
3280                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3281            *sss_ele_cut
3282
3283             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3284                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3285            *sss_ele_cut
3286
3287             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3288                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3289            *sss_ele_cut
3290
3291            enddo
3292            endif
3293
3294
3295 !          do k=1,3
3296 !            ghalf=0.5D0*ggg(k)
3297 !            gelc(k,i)=gelc(k,i)+ghalf
3298 !            gelc(k,j)=gelc(k,j)+ghalf
3299 !          enddo
3300 ! 9/28/08 AL Gradient compotents will be summed only at the end
3301           do k=1,3
3302             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3303             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3304           enddo
3305             gelc_long(3,j)=gelc_long(3,j)+  &
3306           ssgradlipj*eesij/2.0d0*lipscale**2&
3307            *sss_ele_cut
3308
3309             gelc_long(3,i)=gelc_long(3,i)+  &
3310           ssgradlipi*eesij/2.0d0*lipscale**2&
3311            *sss_ele_cut
3312
3313
3314 !
3315 ! Loop over residues i+1 thru j-1.
3316 !
3317 !grad          do k=i+1,j-1
3318 !grad            do l=1,3
3319 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3320 !grad            enddo
3321 !grad          enddo
3322           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3323            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3324           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3325            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3326           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3327            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3328
3329 !          do k=1,3
3330 !            ghalf=0.5D0*ggg(k)
3331 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3332 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3333 !          enddo
3334 ! 9/28/08 AL Gradient compotents will be summed only at the end
3335           do k=1,3
3336             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3337             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3338           enddo
3339
3340 !C Lipidic part for scaling weight
3341            gvdwpp(3,j)=gvdwpp(3,j)+ &
3342           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3343            gvdwpp(3,i)=gvdwpp(3,i)+ &
3344           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3345 !! Loop over residues i+1 thru j-1.
3346 !
3347 !grad          do k=i+1,j-1
3348 !grad            do l=1,3
3349 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3350 !grad            enddo
3351 !grad          enddo
3352 #else
3353           facvdw=(ev1+evdwij)*sss_ele_cut &
3354            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3355
3356           facel=(el1+eesij)*sss_ele_cut
3357           fac1=fac
3358           fac=-3*rrmij*(facvdw+facvdw+facel)
3359           erij(1)=xj*rmij
3360           erij(2)=yj*rmij
3361           erij(3)=zj*rmij
3362 !
3363 ! Radial derivatives. First process both termini of the fragment (i,j)
3364 !
3365           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3366           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3367           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3368 !          do k=1,3
3369 !            ghalf=0.5D0*ggg(k)
3370 !            gelc(k,i)=gelc(k,i)+ghalf
3371 !            gelc(k,j)=gelc(k,j)+ghalf
3372 !          enddo
3373 ! 9/28/08 AL Gradient compotents will be summed only at the end
3374           do k=1,3
3375             gelc_long(k,j)=gelc(k,j)+ggg(k)
3376             gelc_long(k,i)=gelc(k,i)-ggg(k)
3377           enddo
3378 !
3379 ! Loop over residues i+1 thru j-1.
3380 !
3381 !grad          do k=i+1,j-1
3382 !grad            do l=1,3
3383 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3384 !grad            enddo
3385 !grad          enddo
3386 ! 9/28/08 AL Gradient compotents will be summed only at the end
3387           ggg(1)=facvdw*xj &
3388            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3389           ggg(2)=facvdw*yj &
3390            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3391           ggg(3)=facvdw*zj &
3392            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3393
3394           do k=1,3
3395             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3396             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3397           enddo
3398            gvdwpp(3,j)=gvdwpp(3,j)+ &
3399           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3400            gvdwpp(3,i)=gvdwpp(3,i)+ &
3401           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3402
3403 #endif
3404 !
3405 ! Angular part
3406 !
3407           ecosa=2.0D0*fac3*fac1+fac4
3408           fac4=-3.0D0*fac4
3409           fac3=-6.0D0*fac3
3410           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3411           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3412           do k=1,3
3413             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3414             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3415           enddo
3416 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3417 !d   &          (dcosg(k),k=1,3)
3418           do k=1,3
3419             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3420              *fac_shield(i)**2*fac_shield(j)**2 &
3421              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3422
3423           enddo
3424 !          do k=1,3
3425 !            ghalf=0.5D0*ggg(k)
3426 !            gelc(k,i)=gelc(k,i)+ghalf
3427 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3428 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3429 !            gelc(k,j)=gelc(k,j)+ghalf
3430 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3431 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3432 !          enddo
3433 !grad          do k=i+1,j-1
3434 !grad            do l=1,3
3435 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3436 !grad            enddo
3437 !grad          enddo
3438           do k=1,3
3439             gelc(k,i)=gelc(k,i) &
3440                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3441                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3442                      *sss_ele_cut &
3443                      *fac_shield(i)**2*fac_shield(j)**2 &
3444                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3445
3446             gelc(k,j)=gelc(k,j) &
3447                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3448                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3449                      *sss_ele_cut  &
3450                      *fac_shield(i)**2*fac_shield(j)**2  &
3451                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3452
3453             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3454             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3455           enddo
3456
3457           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3458               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3459               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3460 !
3461 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3462 !   energy of a peptide unit is assumed in the form of a second-order
3463 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3464 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3465 !   are computed for EVERY pair of non-contiguous peptide groups.
3466 !
3467           if (j.lt.nres-1) then
3468             j1=j+1
3469             j2=j-1
3470           else
3471             j1=j-1
3472             j2=j-2
3473           endif
3474           kkk=0
3475           do k=1,2
3476             do l=1,2
3477               kkk=kkk+1
3478               muij(kkk)=mu(k,i)*mu(l,j)
3479             enddo
3480           enddo
3481 !d         write (iout,*) 'EELEC: i',i,' j',j
3482 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3483 !d          write(iout,*) 'muij',muij
3484           ury=scalar(uy(1,i),erij)
3485           urz=scalar(uz(1,i),erij)
3486           vry=scalar(uy(1,j),erij)
3487           vrz=scalar(uz(1,j),erij)
3488           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3489           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3490           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3491           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3492           fac=dsqrt(-ael6i)*r3ij
3493           a22=a22*fac
3494           a23=a23*fac
3495           a32=a32*fac
3496           a33=a33*fac
3497 !d          write (iout,'(4i5,4f10.5)')
3498 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3499 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3500 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3501 !d     &      uy(:,j),uz(:,j)
3502 !d          write (iout,'(4f10.5)')
3503 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3504 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3505 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3506 !d           write (iout,'(9f10.5/)')
3507 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3508 ! Derivatives of the elements of A in virtual-bond vectors
3509           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3510           do k=1,3
3511             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3512             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3513             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3514             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3515             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3516             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3517             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3518             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3519             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3520             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3521             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3522             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3523           enddo
3524 ! Compute radial contributions to the gradient
3525           facr=-3.0d0*rrmij
3526           a22der=a22*facr
3527           a23der=a23*facr
3528           a32der=a32*facr
3529           a33der=a33*facr
3530           agg(1,1)=a22der*xj
3531           agg(2,1)=a22der*yj
3532           agg(3,1)=a22der*zj
3533           agg(1,2)=a23der*xj
3534           agg(2,2)=a23der*yj
3535           agg(3,2)=a23der*zj
3536           agg(1,3)=a32der*xj
3537           agg(2,3)=a32der*yj
3538           agg(3,3)=a32der*zj
3539           agg(1,4)=a33der*xj
3540           agg(2,4)=a33der*yj
3541           agg(3,4)=a33der*zj
3542 ! Add the contributions coming from er
3543           fac3=-3.0d0*fac
3544           do k=1,3
3545             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3546             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3547             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3548             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3549           enddo
3550           do k=1,3
3551 ! Derivatives in DC(i)
3552 !grad            ghalf1=0.5d0*agg(k,1)
3553 !grad            ghalf2=0.5d0*agg(k,2)
3554 !grad            ghalf3=0.5d0*agg(k,3)
3555 !grad            ghalf4=0.5d0*agg(k,4)
3556             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3557             -3.0d0*uryg(k,2)*vry)!+ghalf1
3558             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3559             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3560             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3561             -3.0d0*urzg(k,2)*vry)!+ghalf3
3562             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3563             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3564 ! Derivatives in DC(i+1)
3565             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3566             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3567             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3568             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3569             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3570             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3571             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3572             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3573 ! Derivatives in DC(j)
3574             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3575             -3.0d0*vryg(k,2)*ury)!+ghalf1
3576             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3577             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3578             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3579             -3.0d0*vryg(k,2)*urz)!+ghalf3
3580             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3581             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3582 ! Derivatives in DC(j+1) or DC(nres-1)
3583             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3584             -3.0d0*vryg(k,3)*ury)
3585             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3586             -3.0d0*vrzg(k,3)*ury)
3587             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3588             -3.0d0*vryg(k,3)*urz)
3589             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3590             -3.0d0*vrzg(k,3)*urz)
3591 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3592 !grad              do l=1,4
3593 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3594 !grad              enddo
3595 !grad            endif
3596           enddo
3597           acipa(1,1)=a22
3598           acipa(1,2)=a23
3599           acipa(2,1)=a32
3600           acipa(2,2)=a33
3601           a22=-a22
3602           a23=-a23
3603           do l=1,2
3604             do k=1,3
3605               agg(k,l)=-agg(k,l)
3606               aggi(k,l)=-aggi(k,l)
3607               aggi1(k,l)=-aggi1(k,l)
3608               aggj(k,l)=-aggj(k,l)
3609               aggj1(k,l)=-aggj1(k,l)
3610             enddo
3611           enddo
3612           if (j.lt.nres-1) then
3613             a22=-a22
3614             a32=-a32
3615             do l=1,3,2
3616               do k=1,3
3617                 agg(k,l)=-agg(k,l)
3618                 aggi(k,l)=-aggi(k,l)
3619                 aggi1(k,l)=-aggi1(k,l)
3620                 aggj(k,l)=-aggj(k,l)
3621                 aggj1(k,l)=-aggj1(k,l)
3622               enddo
3623             enddo
3624           else
3625             a22=-a22
3626             a23=-a23
3627             a32=-a32
3628             a33=-a33
3629             do l=1,4
3630               do k=1,3
3631                 agg(k,l)=-agg(k,l)
3632                 aggi(k,l)=-aggi(k,l)
3633                 aggi1(k,l)=-aggi1(k,l)
3634                 aggj(k,l)=-aggj(k,l)
3635                 aggj1(k,l)=-aggj1(k,l)
3636               enddo
3637             enddo
3638           endif
3639           ENDIF ! WCORR
3640           IF (wel_loc.gt.0.0d0) THEN
3641 ! Contribution to the local-electrostatic energy coming from the i-j pair
3642           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3643            +a33*muij(4)
3644           if (shield_mode.eq.0) then
3645            fac_shield(i)=1.0
3646            fac_shield(j)=1.0
3647           endif
3648           eel_loc_ij=eel_loc_ij &
3649          *fac_shield(i)*fac_shield(j) &
3650          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3651 !C Now derivative over eel_loc
3652           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3653          (shield_mode.gt.0)) then
3654 !C          print *,i,j
3655
3656           do ilist=1,ishield_list(i)
3657            iresshield=shield_list(ilist,i)
3658            do k=1,3
3659            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3660                                                 /fac_shield(i)&
3661            *sss_ele_cut
3662            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3663                    rlocshield  &
3664           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3665           *sss_ele_cut
3666
3667             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3668            +rlocshield
3669            enddo
3670           enddo
3671           do ilist=1,ishield_list(j)
3672            iresshield=shield_list(ilist,j)
3673            do k=1,3
3674            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3675                                             /fac_shield(j)   &
3676             *sss_ele_cut
3677            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3678                    rlocshield  &
3679       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3680        *sss_ele_cut
3681
3682            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3683                   +rlocshield
3684
3685            enddo
3686           enddo
3687
3688           do k=1,3
3689             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3690                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3691                     *sss_ele_cut
3692             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3693                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3694                     *sss_ele_cut
3695             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3696                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3697                     *sss_ele_cut
3698             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3699                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3700                     *sss_ele_cut
3701
3702            enddo
3703            endif
3704
3705
3706 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3707 !           eel_loc_ij=0.0
3708           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3709                   'eelloc',i,j,eel_loc_ij
3710 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3711 !          if (energy_dec) write (iout,*) "muij",muij
3712 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3713
3714           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3715 ! Partial derivatives in virtual-bond dihedral angles gamma
3716           if (i.gt.1) &
3717           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3718                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3719                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3720                  *sss_ele_cut  &
3721           *fac_shield(i)*fac_shield(j) &
3722           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3723
3724           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3725                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3726                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3727                  *sss_ele_cut &
3728           *fac_shield(i)*fac_shield(j) &
3729           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3730 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3731 !          do l=1,3
3732 !            ggg(1)=(agg(1,1)*muij(1)+ &
3733 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3734 !            *sss_ele_cut &
3735 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3736 !            ggg(2)=(agg(2,1)*muij(1)+ &
3737 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3738 !            *sss_ele_cut &
3739 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3740 !            ggg(3)=(agg(3,1)*muij(1)+ &
3741 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3742 !            *sss_ele_cut &
3743 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3744            xtemp(1)=xj
3745            xtemp(2)=yj
3746            xtemp(3)=zj
3747
3748            do l=1,3
3749             ggg(l)=(agg(l,1)*muij(1)+ &
3750                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3751             *sss_ele_cut &
3752           *fac_shield(i)*fac_shield(j) &
3753           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
3754              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3755
3756
3757             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3758             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3759 !grad            ghalf=0.5d0*ggg(l)
3760 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3761 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3762           enddo
3763             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
3764           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
3765           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3766
3767             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
3768           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
3769           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3770
3771 !grad          do k=i+1,j2
3772 !grad            do l=1,3
3773 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3774 !grad            enddo
3775 !grad          enddo
3776 ! Remaining derivatives of eello
3777           do l=1,3
3778             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
3779                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
3780             *sss_ele_cut &
3781           *fac_shield(i)*fac_shield(j) &
3782           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3783
3784 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3785             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
3786                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
3787             +aggi1(l,4)*muij(4))&
3788             *sss_ele_cut &
3789           *fac_shield(i)*fac_shield(j) &
3790           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3791
3792 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3793             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
3794                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
3795             *sss_ele_cut &
3796           *fac_shield(i)*fac_shield(j) &
3797           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3798
3799 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3800             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
3801                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
3802             +aggj1(l,4)*muij(4))&
3803             *sss_ele_cut &
3804           *fac_shield(i)*fac_shield(j) &
3805           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3806
3807 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3808           enddo
3809           ENDIF
3810 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3811 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3812           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3813              .and. num_conti.le.maxconts) then
3814 !            write (iout,*) i,j," entered corr"
3815 !
3816 ! Calculate the contact function. The ith column of the array JCONT will
3817 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3818 ! greater than I). The arrays FACONT and GACONT will contain the values of
3819 ! the contact function and its derivative.
3820 !           r0ij=1.02D0*rpp(iteli,itelj)
3821 !           r0ij=1.11D0*rpp(iteli,itelj)
3822             r0ij=2.20D0*rpp(iteli,itelj)
3823 !           r0ij=1.55D0*rpp(iteli,itelj)
3824             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3825 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3826             if (fcont.gt.0.0D0) then
3827               num_conti=num_conti+1
3828               if (num_conti.gt.maxconts) then
3829 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3830 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3831                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3832                                ' will skip next contacts for this conf.', num_conti
3833               else
3834                 jcont_hb(num_conti,i)=j
3835 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3836 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3837                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3838                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3839 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3840 !  terms.
3841                 d_cont(num_conti,i)=rij
3842 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3843 !     --- Electrostatic-interaction matrix ---
3844                 a_chuj(1,1,num_conti,i)=a22
3845                 a_chuj(1,2,num_conti,i)=a23
3846                 a_chuj(2,1,num_conti,i)=a32
3847                 a_chuj(2,2,num_conti,i)=a33
3848 !     --- Gradient of rij
3849                 do kkk=1,3
3850                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3851                 enddo
3852                 kkll=0
3853                 do k=1,2
3854                   do l=1,2
3855                     kkll=kkll+1
3856                     do m=1,3
3857                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3858                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3859                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3860                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3861                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3862                     enddo
3863                   enddo
3864                 enddo
3865                 ENDIF
3866                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3867 ! Calculate contact energies
3868                 cosa4=4.0D0*cosa
3869                 wij=cosa-3.0D0*cosb*cosg
3870                 cosbg1=cosb+cosg
3871                 cosbg2=cosb-cosg
3872 !               fac3=dsqrt(-ael6i)/r0ij**3
3873                 fac3=dsqrt(-ael6i)*r3ij
3874 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3875                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3876                 if (ees0tmp.gt.0) then
3877                   ees0pij=dsqrt(ees0tmp)
3878                 else
3879                   ees0pij=0
3880                 endif
3881                 if (shield_mode.eq.0) then
3882                 fac_shield(i)=1.0d0
3883                 fac_shield(j)=1.0d0
3884                 else
3885                 ees0plist(num_conti,i)=j
3886                 endif
3887 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3888                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3889                 if (ees0tmp.gt.0) then
3890                   ees0mij=dsqrt(ees0tmp)
3891                 else
3892                   ees0mij=0
3893                 endif
3894 !               ees0mij=0.0D0
3895                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
3896                      *sss_ele_cut &
3897                      *fac_shield(i)*fac_shield(j)
3898
3899                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
3900                      *sss_ele_cut &
3901                      *fac_shield(i)*fac_shield(j)
3902
3903 ! Diagnostics. Comment out or remove after debugging!
3904 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3905 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3906 !               ees0m(num_conti,i)=0.0D0
3907 ! End diagnostics.
3908 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3909 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3910 ! Angular derivatives of the contact function
3911                 ees0pij1=fac3/ees0pij
3912                 ees0mij1=fac3/ees0mij
3913                 fac3p=-3.0D0*fac3*rrmij
3914                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3915                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3916 !               ees0mij1=0.0D0
3917                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3918                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3919                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3920                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3921                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3922                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3923                 ecosap=ecosa1+ecosa2
3924                 ecosbp=ecosb1+ecosb2
3925                 ecosgp=ecosg1+ecosg2
3926                 ecosam=ecosa1-ecosa2
3927                 ecosbm=ecosb1-ecosb2
3928                 ecosgm=ecosg1-ecosg2
3929 ! Diagnostics
3930 !               ecosap=ecosa1
3931 !               ecosbp=ecosb1
3932 !               ecosgp=ecosg1
3933 !               ecosam=0.0D0
3934 !               ecosbm=0.0D0
3935 !               ecosgm=0.0D0
3936 ! End diagnostics
3937                 facont_hb(num_conti,i)=fcont
3938                 fprimcont=fprimcont/rij
3939 !d              facont_hb(num_conti,i)=1.0D0
3940 ! Following line is for diagnostics.
3941 !d              fprimcont=0.0D0
3942                 do k=1,3
3943                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3944                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3945                 enddo
3946                 do k=1,3
3947                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3948                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3949                 enddo
3950                 gggp(1)=gggp(1)+ees0pijp*xj &
3951                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3952                 gggp(2)=gggp(2)+ees0pijp*yj &
3953                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3954                 gggp(3)=gggp(3)+ees0pijp*zj &
3955                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3956
3957                 gggm(1)=gggm(1)+ees0mijp*xj &
3958                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3959
3960                 gggm(2)=gggm(2)+ees0mijp*yj &
3961                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3962
3963                 gggm(3)=gggm(3)+ees0mijp*zj &
3964                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3965
3966 ! Derivatives due to the contact function
3967                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3968                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3969                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3970                 do k=1,3
3971 !
3972 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3973 !          following the change of gradient-summation algorithm.
3974 !
3975 !grad                  ghalfp=0.5D0*gggp(k)
3976 !grad                  ghalfm=0.5D0*gggm(k)
3977                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3978                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3979                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3980                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3981
3982                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3983                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3984                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3985                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3986
3987                   gacontp_hb3(k,num_conti,i)=gggp(k) &
3988                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3989
3990                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3991                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3992                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3993                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3994
3995                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3996                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3997                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
3998                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3999
4000                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4001                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4002
4003                 enddo
4004 ! Diagnostics. Comment out or remove after debugging!
4005 !diag           do k=1,3
4006 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4007 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4008 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4009 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4010 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4011 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4012 !diag           enddo
4013               ENDIF ! wcorr
4014               endif  ! num_conti.le.maxconts
4015             endif  ! fcont.gt.0
4016           endif    ! j.gt.i+1
4017           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4018             do k=1,4
4019               do l=1,3
4020                 ghalf=0.5d0*agg(l,k)
4021                 aggi(l,k)=aggi(l,k)+ghalf
4022                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4023                 aggj(l,k)=aggj(l,k)+ghalf
4024               enddo
4025             enddo
4026             if (j.eq.nres-1 .and. i.lt.j-2) then
4027               do k=1,4
4028                 do l=1,3
4029                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4030                 enddo
4031               enddo
4032             endif
4033           endif
4034  128  continue
4035 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4036       return
4037       end subroutine eelecij
4038 !-----------------------------------------------------------------------------
4039       subroutine eturn3(i,eello_turn3)
4040 ! Third- and fourth-order contributions from turns
4041
4042       use comm_locel
4043 !      implicit real*8 (a-h,o-z)
4044 !      include 'DIMENSIONS'
4045 !      include 'COMMON.IOUNITS'
4046 !      include 'COMMON.GEO'
4047 !      include 'COMMON.VAR'
4048 !      include 'COMMON.LOCAL'
4049 !      include 'COMMON.CHAIN'
4050 !      include 'COMMON.DERIV'
4051 !      include 'COMMON.INTERACT'
4052 !      include 'COMMON.CONTACTS'
4053 !      include 'COMMON.TORSION'
4054 !      include 'COMMON.VECTORS'
4055 !      include 'COMMON.FFIELD'
4056 !      include 'COMMON.CONTROL'
4057       real(kind=8),dimension(3) :: ggg
4058       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4059         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4060       real(kind=8),dimension(2) :: auxvec,auxvec1
4061 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4062       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4063 !el      integer :: num_conti,j1,j2
4064 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4065 !el        dz_normi,xmedi,ymedi,zmedi
4066
4067 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4068 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4069 !el         num_conti,j1,j2
4070 !el local variables
4071       integer :: i,j,l,k,ilist,iresshield
4072       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4073
4074       j=i+2
4075 !      write (iout,*) "eturn3",i,j,j1,j2
4076           zj=(c(3,j)+c(3,j+1))/2.0d0
4077           zj=mod(zj,boxzsize)
4078           if (zj.lt.0) zj=zj+boxzsize
4079           if ((zj.lt.0)) write (*,*) "CHUJ"
4080        if ((zj.gt.bordlipbot)  &
4081         .and.(zj.lt.bordliptop)) then
4082 !C the energy transfer exist
4083         if (zj.lt.buflipbot) then
4084 !C what fraction I am in
4085          fracinbuf=1.0d0-     &
4086              ((zj-bordlipbot)/lipbufthick)
4087 !C lipbufthick is thickenes of lipid buffore
4088          sslipj=sscalelip(fracinbuf)
4089          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4090         elseif (zj.gt.bufliptop) then
4091          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4092          sslipj=sscalelip(fracinbuf)
4093          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4094         else
4095          sslipj=1.0d0
4096          ssgradlipj=0.0
4097         endif
4098        else
4099          sslipj=0.0d0
4100          ssgradlipj=0.0
4101        endif
4102
4103       a_temp(1,1)=a22
4104       a_temp(1,2)=a23
4105       a_temp(2,1)=a32
4106       a_temp(2,2)=a33
4107 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4108 !
4109 !               Third-order contributions
4110 !
4111 !                 (i+2)o----(i+3)
4112 !                      | |
4113 !                      | |
4114 !                 (i+1)o----i
4115 !
4116 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4117 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4118         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4119         call transpose2(auxmat(1,1),auxmat1(1,1))
4120         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4121         if (shield_mode.eq.0) then
4122         fac_shield(i)=1.0d0
4123         fac_shield(j)=1.0d0
4124         endif
4125
4126         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4127          *fac_shield(i)*fac_shield(j)  &
4128          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4129         eello_t3= &
4130         0.5d0*(pizda(1,1)+pizda(2,2)) &
4131         *fac_shield(i)*fac_shield(j)
4132
4133         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4134                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4135           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4136        (shield_mode.gt.0)) then
4137 !C          print *,i,j
4138
4139           do ilist=1,ishield_list(i)
4140            iresshield=shield_list(ilist,i)
4141            do k=1,3
4142            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4143            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4144                    rlocshield &
4145            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4146             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4147              +rlocshield
4148            enddo
4149           enddo
4150           do ilist=1,ishield_list(j)
4151            iresshield=shield_list(ilist,j)
4152            do k=1,3
4153            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4154            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4155                    rlocshield &
4156            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4157            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4158                   +rlocshield
4159
4160            enddo
4161           enddo
4162
4163           do k=1,3
4164             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4165                    grad_shield(k,i)*eello_t3/fac_shield(i)
4166             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4167                    grad_shield(k,j)*eello_t3/fac_shield(j)
4168             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4169                    grad_shield(k,i)*eello_t3/fac_shield(i)
4170             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4171                    grad_shield(k,j)*eello_t3/fac_shield(j)
4172            enddo
4173            endif
4174
4175 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4176 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4177 !d     &    ' eello_turn3_num',4*eello_turn3_num
4178 ! Derivatives in gamma(i)
4179         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4180         call transpose2(auxmat2(1,1),auxmat3(1,1))
4181         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4182         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4183           *fac_shield(i)*fac_shield(j)        &
4184           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4185 ! Derivatives in gamma(i+1)
4186         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4187         call transpose2(auxmat2(1,1),auxmat3(1,1))
4188         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4189         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4190           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4191           *fac_shield(i)*fac_shield(j)        &
4192           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4193
4194 ! Cartesian derivatives
4195         do l=1,3
4196 !            ghalf1=0.5d0*agg(l,1)
4197 !            ghalf2=0.5d0*agg(l,2)
4198 !            ghalf3=0.5d0*agg(l,3)
4199 !            ghalf4=0.5d0*agg(l,4)
4200           a_temp(1,1)=aggi(l,1)!+ghalf1
4201           a_temp(1,2)=aggi(l,2)!+ghalf2
4202           a_temp(2,1)=aggi(l,3)!+ghalf3
4203           a_temp(2,2)=aggi(l,4)!+ghalf4
4204           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4205           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4206             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4207           *fac_shield(i)*fac_shield(j)      &
4208           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4209
4210           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4211           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4212           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4213           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4214           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4215           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4216             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4217           *fac_shield(i)*fac_shield(j)        &
4218           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4219
4220           a_temp(1,1)=aggj(l,1)!+ghalf1
4221           a_temp(1,2)=aggj(l,2)!+ghalf2
4222           a_temp(2,1)=aggj(l,3)!+ghalf3
4223           a_temp(2,2)=aggj(l,4)!+ghalf4
4224           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4225           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4226             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4227           *fac_shield(i)*fac_shield(j)      &
4228           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4229
4230           a_temp(1,1)=aggj1(l,1)
4231           a_temp(1,2)=aggj1(l,2)
4232           a_temp(2,1)=aggj1(l,3)
4233           a_temp(2,2)=aggj1(l,4)
4234           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4235           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4236             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4237           *fac_shield(i)*fac_shield(j)        &
4238           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4239         enddo
4240          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4241           ssgradlipi*eello_t3/4.0d0*lipscale
4242          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4243           ssgradlipj*eello_t3/4.0d0*lipscale
4244          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4245           ssgradlipi*eello_t3/4.0d0*lipscale
4246          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4247           ssgradlipj*eello_t3/4.0d0*lipscale
4248
4249       return
4250       end subroutine eturn3
4251 !-----------------------------------------------------------------------------
4252       subroutine eturn4(i,eello_turn4)
4253 ! Third- and fourth-order contributions from turns
4254
4255       use comm_locel
4256 !      implicit real*8 (a-h,o-z)
4257 !      include 'DIMENSIONS'
4258 !      include 'COMMON.IOUNITS'
4259 !      include 'COMMON.GEO'
4260 !      include 'COMMON.VAR'
4261 !      include 'COMMON.LOCAL'
4262 !      include 'COMMON.CHAIN'
4263 !      include 'COMMON.DERIV'
4264 !      include 'COMMON.INTERACT'
4265 !      include 'COMMON.CONTACTS'
4266 !      include 'COMMON.TORSION'
4267 !      include 'COMMON.VECTORS'
4268 !      include 'COMMON.FFIELD'
4269 !      include 'COMMON.CONTROL'
4270       real(kind=8),dimension(3) :: ggg
4271       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4272         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4273       real(kind=8),dimension(2) :: auxvec,auxvec1
4274 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4275       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4276 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4277 !el        dz_normi,xmedi,ymedi,zmedi
4278 !el      integer :: num_conti,j1,j2
4279 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4280 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4281 !el          num_conti,j1,j2
4282 !el local variables
4283       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4284       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4285          rlocshield
4286
4287       j=i+3
4288 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4289 !
4290 !               Fourth-order contributions
4291 !
4292 !                 (i+3)o----(i+4)
4293 !                     /  |
4294 !               (i+2)o   |
4295 !                     \  |
4296 !                 (i+1)o----i
4297 !
4298 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4299 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4300 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4301           zj=(c(3,j)+c(3,j+1))/2.0d0
4302           zj=mod(zj,boxzsize)
4303           if (zj.lt.0) zj=zj+boxzsize
4304        if ((zj.gt.bordlipbot)  &
4305         .and.(zj.lt.bordliptop)) then
4306 !C the energy transfer exist
4307         if (zj.lt.buflipbot) then
4308 !C what fraction I am in
4309          fracinbuf=1.0d0-     &
4310              ((zj-bordlipbot)/lipbufthick)
4311 !C lipbufthick is thickenes of lipid buffore
4312          sslipj=sscalelip(fracinbuf)
4313          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4314         elseif (zj.gt.bufliptop) then
4315          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4316          sslipj=sscalelip(fracinbuf)
4317          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4318         else
4319          sslipj=1.0d0
4320          ssgradlipj=0.0
4321         endif
4322        else
4323          sslipj=0.0d0
4324          ssgradlipj=0.0
4325        endif
4326
4327         a_temp(1,1)=a22
4328         a_temp(1,2)=a23
4329         a_temp(2,1)=a32
4330         a_temp(2,2)=a33
4331         iti1=itortyp(itype(i+1,1))
4332         iti2=itortyp(itype(i+2,1))
4333         iti3=itortyp(itype(i+3,1))
4334 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4335         call transpose2(EUg(1,1,i+1),e1t(1,1))
4336         call transpose2(Eug(1,1,i+2),e2t(1,1))
4337         call transpose2(Eug(1,1,i+3),e3t(1,1))
4338         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4339         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4340         s1=scalar2(b1(1,iti2),auxvec(1))
4341         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4342         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4343         s2=scalar2(b1(1,iti1),auxvec(1))
4344         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4345         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4346         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4347         if (shield_mode.eq.0) then
4348         fac_shield(i)=1.0
4349         fac_shield(j)=1.0
4350         endif
4351
4352         eello_turn4=eello_turn4-(s1+s2+s3) &
4353         *fac_shield(i)*fac_shield(j)       &
4354         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4355         eello_t4=-(s1+s2+s3)  &
4356           *fac_shield(i)*fac_shield(j)
4357 !C Now derivative over shield:
4358           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4359          (shield_mode.gt.0)) then
4360 !C          print *,i,j
4361
4362           do ilist=1,ishield_list(i)
4363            iresshield=shield_list(ilist,i)
4364            do k=1,3
4365            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4366            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4367                    rlocshield &
4368             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4369             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4370            +rlocshield
4371            enddo
4372           enddo
4373           do ilist=1,ishield_list(j)
4374            iresshield=shield_list(ilist,j)
4375            do k=1,3
4376            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4377            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4378                    rlocshield  &
4379            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4380            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4381                   +rlocshield
4382
4383            enddo
4384           enddo
4385
4386           do k=1,3
4387             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4388                    grad_shield(k,i)*eello_t4/fac_shield(i)
4389             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4390                    grad_shield(k,j)*eello_t4/fac_shield(j)
4391             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4392                    grad_shield(k,i)*eello_t4/fac_shield(i)
4393             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4394                    grad_shield(k,j)*eello_t4/fac_shield(j)
4395            enddo
4396            endif
4397
4398         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4399            'eturn4',i,j,-(s1+s2+s3)
4400 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4401 !d     &    ' eello_turn4_num',8*eello_turn4_num
4402 ! Derivatives in gamma(i)
4403         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4404         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4405         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4406         s1=scalar2(b1(1,iti2),auxvec(1))
4407         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4408         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4409         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4410        *fac_shield(i)*fac_shield(j)  &
4411        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4412
4413 ! Derivatives in gamma(i+1)
4414         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4415         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4416         s2=scalar2(b1(1,iti1),auxvec(1))
4417         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4418         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4419         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4420         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4421        *fac_shield(i)*fac_shield(j)  &
4422        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4423
4424 ! Derivatives in gamma(i+2)
4425         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4426         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4427         s1=scalar2(b1(1,iti2),auxvec(1))
4428         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4429         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4430         s2=scalar2(b1(1,iti1),auxvec(1))
4431         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4432         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4433         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4434         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4435        *fac_shield(i)*fac_shield(j)  &
4436        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4437
4438 ! Cartesian derivatives
4439 ! Derivatives of this turn contributions in DC(i+2)
4440         if (j.lt.nres-1) then
4441           do l=1,3
4442             a_temp(1,1)=agg(l,1)
4443             a_temp(1,2)=agg(l,2)
4444             a_temp(2,1)=agg(l,3)
4445             a_temp(2,2)=agg(l,4)
4446             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4447             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4448             s1=scalar2(b1(1,iti2),auxvec(1))
4449             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4450             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4451             s2=scalar2(b1(1,iti1),auxvec(1))
4452             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4453             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4454             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4455             ggg(l)=-(s1+s2+s3)
4456             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4457        *fac_shield(i)*fac_shield(j)  &
4458        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4459
4460           enddo
4461         endif
4462 ! Remaining derivatives of this turn contribution
4463         do l=1,3
4464           a_temp(1,1)=aggi(l,1)
4465           a_temp(1,2)=aggi(l,2)
4466           a_temp(2,1)=aggi(l,3)
4467           a_temp(2,2)=aggi(l,4)
4468           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4469           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4470           s1=scalar2(b1(1,iti2),auxvec(1))
4471           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4472           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4473           s2=scalar2(b1(1,iti1),auxvec(1))
4474           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4475           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4476           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4477           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4478          *fac_shield(i)*fac_shield(j)  &
4479          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4480
4481
4482           a_temp(1,1)=aggi1(l,1)
4483           a_temp(1,2)=aggi1(l,2)
4484           a_temp(2,1)=aggi1(l,3)
4485           a_temp(2,2)=aggi1(l,4)
4486           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4487           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4488           s1=scalar2(b1(1,iti2),auxvec(1))
4489           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4490           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4491           s2=scalar2(b1(1,iti1),auxvec(1))
4492           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4493           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4494           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4495           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4496          *fac_shield(i)*fac_shield(j)  &
4497          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4498
4499
4500           a_temp(1,1)=aggj(l,1)
4501           a_temp(1,2)=aggj(l,2)
4502           a_temp(2,1)=aggj(l,3)
4503           a_temp(2,2)=aggj(l,4)
4504           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4505           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4506           s1=scalar2(b1(1,iti2),auxvec(1))
4507           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4508           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4509           s2=scalar2(b1(1,iti1),auxvec(1))
4510           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4511           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4512           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4513           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4514          *fac_shield(i)*fac_shield(j)  &
4515          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4516
4517
4518           a_temp(1,1)=aggj1(l,1)
4519           a_temp(1,2)=aggj1(l,2)
4520           a_temp(2,1)=aggj1(l,3)
4521           a_temp(2,2)=aggj1(l,4)
4522           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4523           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4524           s1=scalar2(b1(1,iti2),auxvec(1))
4525           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4526           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4527           s2=scalar2(b1(1,iti1),auxvec(1))
4528           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4529           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4530           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4531 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4532           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4533          *fac_shield(i)*fac_shield(j)  &
4534          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4535
4536         enddo
4537          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4538           ssgradlipi*eello_t4/4.0d0*lipscale
4539          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4540           ssgradlipj*eello_t4/4.0d0*lipscale
4541          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4542           ssgradlipi*eello_t4/4.0d0*lipscale
4543          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4544           ssgradlipj*eello_t4/4.0d0*lipscale
4545
4546       return
4547       end subroutine eturn4
4548 !-----------------------------------------------------------------------------
4549       subroutine unormderiv(u,ugrad,unorm,ungrad)
4550 ! This subroutine computes the derivatives of a normalized vector u, given
4551 ! the derivatives computed without normalization conditions, ugrad. Returns
4552 ! ungrad.
4553 !      implicit none
4554       real(kind=8),dimension(3) :: u,vec
4555       real(kind=8),dimension(3,3) ::ugrad,ungrad
4556       real(kind=8) :: unorm     !,scalar
4557       integer :: i,j
4558 !      write (2,*) 'ugrad',ugrad
4559 !      write (2,*) 'u',u
4560       do i=1,3
4561         vec(i)=scalar(ugrad(1,i),u(1))
4562       enddo
4563 !      write (2,*) 'vec',vec
4564       do i=1,3
4565         do j=1,3
4566           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4567         enddo
4568       enddo
4569 !      write (2,*) 'ungrad',ungrad
4570       return
4571       end subroutine unormderiv
4572 !-----------------------------------------------------------------------------
4573       subroutine escp_soft_sphere(evdw2,evdw2_14)
4574 !
4575 ! This subroutine calculates the excluded-volume interaction energy between
4576 ! peptide-group centers and side chains and its gradient in virtual-bond and
4577 ! side-chain vectors.
4578 !
4579 !      implicit real*8 (a-h,o-z)
4580 !      include 'DIMENSIONS'
4581 !      include 'COMMON.GEO'
4582 !      include 'COMMON.VAR'
4583 !      include 'COMMON.LOCAL'
4584 !      include 'COMMON.CHAIN'
4585 !      include 'COMMON.DERIV'
4586 !      include 'COMMON.INTERACT'
4587 !      include 'COMMON.FFIELD'
4588 !      include 'COMMON.IOUNITS'
4589 !      include 'COMMON.CONTROL'
4590       real(kind=8),dimension(3) :: ggg
4591 !el local variables
4592       integer :: i,iint,j,k,iteli,itypj
4593       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4594                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4595
4596       evdw2=0.0D0
4597       evdw2_14=0.0d0
4598       r0_scp=4.5d0
4599 !d    print '(a)','Enter ESCP'
4600 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4601       do i=iatscp_s,iatscp_e
4602         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4603         iteli=itel(i)
4604         xi=0.5D0*(c(1,i)+c(1,i+1))
4605         yi=0.5D0*(c(2,i)+c(2,i+1))
4606         zi=0.5D0*(c(3,i)+c(3,i+1))
4607
4608         do iint=1,nscp_gr(i)
4609
4610         do j=iscpstart(i,iint),iscpend(i,iint)
4611           if (itype(j,1).eq.ntyp1) cycle
4612           itypj=iabs(itype(j,1))
4613 ! Uncomment following three lines for SC-p interactions
4614 !         xj=c(1,nres+j)-xi
4615 !         yj=c(2,nres+j)-yi
4616 !         zj=c(3,nres+j)-zi
4617 ! Uncomment following three lines for Ca-p interactions
4618           xj=c(1,j)-xi
4619           yj=c(2,j)-yi
4620           zj=c(3,j)-zi
4621           rij=xj*xj+yj*yj+zj*zj
4622           r0ij=r0_scp
4623           r0ijsq=r0ij*r0ij
4624           if (rij.lt.r0ijsq) then
4625             evdwij=0.25d0*(rij-r0ijsq)**2
4626             fac=rij-r0ijsq
4627           else
4628             evdwij=0.0d0
4629             fac=0.0d0
4630           endif
4631           evdw2=evdw2+evdwij
4632 !
4633 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4634 !
4635           ggg(1)=xj*fac
4636           ggg(2)=yj*fac
4637           ggg(3)=zj*fac
4638 !grad          if (j.lt.i) then
4639 !d          write (iout,*) 'j<i'
4640 ! Uncomment following three lines for SC-p interactions
4641 !           do k=1,3
4642 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4643 !           enddo
4644 !grad          else
4645 !d          write (iout,*) 'j>i'
4646 !grad            do k=1,3
4647 !grad              ggg(k)=-ggg(k)
4648 ! Uncomment following line for SC-p interactions
4649 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4650 !grad            enddo
4651 !grad          endif
4652 !grad          do k=1,3
4653 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4654 !grad          enddo
4655 !grad          kstart=min0(i+1,j)
4656 !grad          kend=max0(i-1,j-1)
4657 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4658 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4659 !grad          do k=kstart,kend
4660 !grad            do l=1,3
4661 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4662 !grad            enddo
4663 !grad          enddo
4664           do k=1,3
4665             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4666             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4667           enddo
4668         enddo
4669
4670         enddo ! iint
4671       enddo ! i
4672       return
4673       end subroutine escp_soft_sphere
4674 !-----------------------------------------------------------------------------
4675       subroutine escp(evdw2,evdw2_14)
4676 !
4677 ! This subroutine calculates the excluded-volume interaction energy between
4678 ! peptide-group centers and side chains and its gradient in virtual-bond and
4679 ! side-chain vectors.
4680 !
4681 !      implicit real*8 (a-h,o-z)
4682 !      include 'DIMENSIONS'
4683 !      include 'COMMON.GEO'
4684 !      include 'COMMON.VAR'
4685 !      include 'COMMON.LOCAL'
4686 !      include 'COMMON.CHAIN'
4687 !      include 'COMMON.DERIV'
4688 !      include 'COMMON.INTERACT'
4689 !      include 'COMMON.FFIELD'
4690 !      include 'COMMON.IOUNITS'
4691 !      include 'COMMON.CONTROL'
4692       real(kind=8),dimension(3) :: ggg
4693 !el local variables
4694       integer :: i,iint,j,k,iteli,itypj,subchap
4695       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4696                    e1,e2,evdwij,rij
4697       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4698                     dist_temp, dist_init
4699       integer xshift,yshift,zshift
4700
4701       evdw2=0.0D0
4702       evdw2_14=0.0d0
4703 !d    print '(a)','Enter ESCP'
4704 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4705       do i=iatscp_s,iatscp_e
4706         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4707         iteli=itel(i)
4708         xi=0.5D0*(c(1,i)+c(1,i+1))
4709         yi=0.5D0*(c(2,i)+c(2,i+1))
4710         zi=0.5D0*(c(3,i)+c(3,i+1))
4711           xi=mod(xi,boxxsize)
4712           if (xi.lt.0) xi=xi+boxxsize
4713           yi=mod(yi,boxysize)
4714           if (yi.lt.0) yi=yi+boxysize
4715           zi=mod(zi,boxzsize)
4716           if (zi.lt.0) zi=zi+boxzsize
4717
4718         do iint=1,nscp_gr(i)
4719
4720         do j=iscpstart(i,iint),iscpend(i,iint)
4721           itypj=iabs(itype(j,1))
4722           if (itypj.eq.ntyp1) cycle
4723 ! Uncomment following three lines for SC-p interactions
4724 !         xj=c(1,nres+j)-xi
4725 !         yj=c(2,nres+j)-yi
4726 !         zj=c(3,nres+j)-zi
4727 ! Uncomment following three lines for Ca-p interactions
4728 !          xj=c(1,j)-xi
4729 !          yj=c(2,j)-yi
4730 !          zj=c(3,j)-zi
4731           xj=c(1,j)
4732           yj=c(2,j)
4733           zj=c(3,j)
4734           xj=mod(xj,boxxsize)
4735           if (xj.lt.0) xj=xj+boxxsize
4736           yj=mod(yj,boxysize)
4737           if (yj.lt.0) yj=yj+boxysize
4738           zj=mod(zj,boxzsize)
4739           if (zj.lt.0) zj=zj+boxzsize
4740       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4741       xj_safe=xj
4742       yj_safe=yj
4743       zj_safe=zj
4744       subchap=0
4745       do xshift=-1,1
4746       do yshift=-1,1
4747       do zshift=-1,1
4748           xj=xj_safe+xshift*boxxsize
4749           yj=yj_safe+yshift*boxysize
4750           zj=zj_safe+zshift*boxzsize
4751           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4752           if(dist_temp.lt.dist_init) then
4753             dist_init=dist_temp
4754             xj_temp=xj
4755             yj_temp=yj
4756             zj_temp=zj
4757             subchap=1
4758           endif
4759        enddo
4760        enddo
4761        enddo
4762        if (subchap.eq.1) then
4763           xj=xj_temp-xi
4764           yj=yj_temp-yi
4765           zj=zj_temp-zi
4766        else
4767           xj=xj_safe-xi
4768           yj=yj_safe-yi
4769           zj=zj_safe-zi
4770        endif
4771
4772           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4773           rij=dsqrt(1.0d0/rrij)
4774             sss_ele_cut=sscale_ele(rij)
4775             sss_ele_grad=sscagrad_ele(rij)
4776 !            print *,sss_ele_cut,sss_ele_grad,&
4777 !            (rij),r_cut_ele,rlamb_ele
4778             if (sss_ele_cut.le.0.0) cycle
4779           fac=rrij**expon2
4780           e1=fac*fac*aad(itypj,iteli)
4781           e2=fac*bad(itypj,iteli)
4782           if (iabs(j-i) .le. 2) then
4783             e1=scal14*e1
4784             e2=scal14*e2
4785             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
4786           endif
4787           evdwij=e1+e2
4788           evdw2=evdw2+evdwij*sss_ele_cut
4789 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
4790 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
4791           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4792              'evdw2',i,j,evdwij
4793 !
4794 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4795 !
4796           fac=-(evdwij+e1)*rrij*sss_ele_cut
4797           fac=fac+evdwij*sss_ele_grad/rij/expon
4798           ggg(1)=xj*fac
4799           ggg(2)=yj*fac
4800           ggg(3)=zj*fac
4801 !grad          if (j.lt.i) then
4802 !d          write (iout,*) 'j<i'
4803 ! Uncomment following three lines for SC-p interactions
4804 !           do k=1,3
4805 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4806 !           enddo
4807 !grad          else
4808 !d          write (iout,*) 'j>i'
4809 !grad            do k=1,3
4810 !grad              ggg(k)=-ggg(k)
4811 ! Uncomment following line for SC-p interactions
4812 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4813 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4814 !grad            enddo
4815 !grad          endif
4816 !grad          do k=1,3
4817 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4818 !grad          enddo
4819 !grad          kstart=min0(i+1,j)
4820 !grad          kend=max0(i-1,j-1)
4821 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4822 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4823 !grad          do k=kstart,kend
4824 !grad            do l=1,3
4825 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4826 !grad            enddo
4827 !grad          enddo
4828           do k=1,3
4829             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4830             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4831           enddo
4832         enddo
4833
4834         enddo ! iint
4835       enddo ! i
4836       do i=1,nct
4837         do j=1,3
4838           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4839           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4840           gradx_scp(j,i)=expon*gradx_scp(j,i)
4841         enddo
4842       enddo
4843 !******************************************************************************
4844 !
4845 !                              N O T E !!!
4846 !
4847 ! To save time the factor EXPON has been extracted from ALL components
4848 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
4849 ! use!
4850 !
4851 !******************************************************************************
4852       return
4853       end subroutine escp
4854 !-----------------------------------------------------------------------------
4855       subroutine edis(ehpb)
4856 !
4857 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4858 !
4859 !      implicit real*8 (a-h,o-z)
4860 !      include 'DIMENSIONS'
4861 !      include 'COMMON.SBRIDGE'
4862 !      include 'COMMON.CHAIN'
4863 !      include 'COMMON.DERIV'
4864 !      include 'COMMON.VAR'
4865 !      include 'COMMON.INTERACT'
4866 !      include 'COMMON.IOUNITS'
4867       real(kind=8),dimension(3) :: ggg
4868 !el local variables
4869       integer :: i,j,ii,jj,iii,jjj,k
4870       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
4871
4872       ehpb=0.0D0
4873 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4874 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
4875       if (link_end.eq.0) return
4876       do i=link_start,link_end
4877 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4878 ! CA-CA distance used in regularization of structure.
4879         ii=ihpb(i)
4880         jj=jhpb(i)
4881 ! iii and jjj point to the residues for which the distance is assigned.
4882         if (ii.gt.nres) then
4883           iii=ii-nres
4884           jjj=jj-nres
4885         else
4886           iii=ii
4887           jjj=jj
4888         endif
4889 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4890 !     &    dhpb(i),dhpb1(i),forcon(i)
4891 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
4892 !    distance and angle dependent SS bond potential.
4893 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4894 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4895         if (.not.dyn_ss .and. i.le.nss) then
4896 ! 15/02/13 CC dynamic SSbond - additional check
4897          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
4898         iabs(itype(jjj,1)).eq.1) then
4899           call ssbond_ene(iii,jjj,eij)
4900           ehpb=ehpb+2*eij
4901 !d          write (iout,*) "eij",eij
4902          endif
4903         else if (ii.gt.nres .and. jj.gt.nres) then
4904 !c Restraints from contact prediction
4905           dd=dist(ii,jj)
4906           if (constr_dist.eq.11) then
4907             ehpb=ehpb+fordepth(i)**4.0d0 &
4908                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4909             fac=fordepth(i)**4.0d0 &
4910                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4911           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
4912             ehpb,fordepth(i),dd
4913            else
4914           if (dhpb1(i).gt.0.0d0) then
4915             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4916             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4917 !c            write (iout,*) "beta nmr",
4918 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4919           else
4920             dd=dist(ii,jj)
4921             rdis=dd-dhpb(i)
4922 !C Get the force constant corresponding to this distance.
4923             waga=forcon(i)
4924 !C Calculate the contribution to energy.
4925             ehpb=ehpb+waga*rdis*rdis
4926 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4927 !C
4928 !C Evaluate gradient.
4929 !C
4930             fac=waga*rdis/dd
4931           endif
4932           endif
4933           do j=1,3
4934             ggg(j)=fac*(c(j,jj)-c(j,ii))
4935           enddo
4936           do j=1,3
4937             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4938             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4939           enddo
4940           do k=1,3
4941             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4942             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4943           enddo
4944         else
4945           dd=dist(ii,jj)
4946           if (constr_dist.eq.11) then
4947             ehpb=ehpb+fordepth(i)**4.0d0 &
4948                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4949             fac=fordepth(i)**4.0d0 &
4950                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4951           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
4952          ehpb,fordepth(i),dd
4953            else
4954           if (dhpb1(i).gt.0.0d0) then
4955             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4956             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4957 !c            write (iout,*) "alph nmr",
4958 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4959           else
4960             rdis=dd-dhpb(i)
4961 !C Get the force constant corresponding to this distance.
4962             waga=forcon(i)
4963 !C Calculate the contribution to energy.
4964             ehpb=ehpb+waga*rdis*rdis
4965 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4966 !C
4967 !C Evaluate gradient.
4968 !C
4969             fac=waga*rdis/dd
4970           endif
4971           endif
4972
4973             do j=1,3
4974               ggg(j)=fac*(c(j,jj)-c(j,ii))
4975             enddo
4976 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4977 !C If this is a SC-SC distance, we need to calculate the contributions to the
4978 !C Cartesian gradient in the SC vectors (ghpbx).
4979           if (iii.lt.ii) then
4980           do j=1,3
4981             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4982             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4983           enddo
4984           endif
4985 !cgrad        do j=iii,jjj-1
4986 !cgrad          do k=1,3
4987 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4988 !cgrad          enddo
4989 !cgrad        enddo
4990           do k=1,3
4991             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4992             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4993           enddo
4994         endif
4995       enddo
4996       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
4997
4998       return
4999       end subroutine edis
5000 !-----------------------------------------------------------------------------
5001       subroutine ssbond_ene(i,j,eij)
5002 !
5003 ! Calculate the distance and angle dependent SS-bond potential energy
5004 ! using a free-energy function derived based on RHF/6-31G** ab initio
5005 ! calculations of diethyl disulfide.
5006 !
5007 ! A. Liwo and U. Kozlowska, 11/24/03
5008 !
5009 !      implicit real*8 (a-h,o-z)
5010 !      include 'DIMENSIONS'
5011 !      include 'COMMON.SBRIDGE'
5012 !      include 'COMMON.CHAIN'
5013 !      include 'COMMON.DERIV'
5014 !      include 'COMMON.LOCAL'
5015 !      include 'COMMON.INTERACT'
5016 !      include 'COMMON.VAR'
5017 !      include 'COMMON.IOUNITS'
5018       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5019 !el local variables
5020       integer :: i,j,itypi,itypj,k
5021       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5022                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5023                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5024                    cosphi,ggk
5025
5026       itypi=iabs(itype(i,1))
5027       xi=c(1,nres+i)
5028       yi=c(2,nres+i)
5029       zi=c(3,nres+i)
5030       dxi=dc_norm(1,nres+i)
5031       dyi=dc_norm(2,nres+i)
5032       dzi=dc_norm(3,nres+i)
5033 !      dsci_inv=dsc_inv(itypi)
5034       dsci_inv=vbld_inv(nres+i)
5035       itypj=iabs(itype(j,1))
5036 !      dscj_inv=dsc_inv(itypj)
5037       dscj_inv=vbld_inv(nres+j)
5038       xj=c(1,nres+j)-xi
5039       yj=c(2,nres+j)-yi
5040       zj=c(3,nres+j)-zi
5041       dxj=dc_norm(1,nres+j)
5042       dyj=dc_norm(2,nres+j)
5043       dzj=dc_norm(3,nres+j)
5044       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5045       rij=dsqrt(rrij)
5046       erij(1)=xj*rij
5047       erij(2)=yj*rij
5048       erij(3)=zj*rij
5049       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5050       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5051       om12=dxi*dxj+dyi*dyj+dzi*dzj
5052       do k=1,3
5053         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5054         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5055       enddo
5056       rij=1.0d0/rij
5057       deltad=rij-d0cm
5058       deltat1=1.0d0-om1
5059       deltat2=1.0d0+om2
5060       deltat12=om2-om1+2.0d0
5061       cosphi=om12-om1*om2
5062       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5063         +akct*deltad*deltat12 &
5064         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5065 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5066 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5067 !     &  " deltat12",deltat12," eij",eij
5068       ed=2*akcm*deltad+akct*deltat12
5069       pom1=akct*deltad
5070       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5071       eom1=-2*akth*deltat1-pom1-om2*pom2
5072       eom2= 2*akth*deltat2+pom1-om1*pom2
5073       eom12=pom2
5074       do k=1,3
5075         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5076         ghpbx(k,i)=ghpbx(k,i)-ggk &
5077                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5078                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5079         ghpbx(k,j)=ghpbx(k,j)+ggk &
5080                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5081                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5082         ghpbc(k,i)=ghpbc(k,i)-ggk
5083         ghpbc(k,j)=ghpbc(k,j)+ggk
5084       enddo
5085 !
5086 ! Calculate the components of the gradient in DC and X
5087 !
5088 !grad      do k=i,j-1
5089 !grad        do l=1,3
5090 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5091 !grad        enddo
5092 !grad      enddo
5093       return
5094       end subroutine ssbond_ene
5095 !-----------------------------------------------------------------------------
5096       subroutine ebond(estr)
5097 !
5098 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5099 !
5100 !      implicit real*8 (a-h,o-z)
5101 !      include 'DIMENSIONS'
5102 !      include 'COMMON.LOCAL'
5103 !      include 'COMMON.GEO'
5104 !      include 'COMMON.INTERACT'
5105 !      include 'COMMON.DERIV'
5106 !      include 'COMMON.VAR'
5107 !      include 'COMMON.CHAIN'
5108 !      include 'COMMON.IOUNITS'
5109 !      include 'COMMON.NAMES'
5110 !      include 'COMMON.FFIELD'
5111 !      include 'COMMON.CONTROL'
5112 !      include 'COMMON.SETUP'
5113       real(kind=8),dimension(3) :: u,ud
5114 !el local variables
5115       integer :: i,j,iti,nbi,k
5116       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5117                    uprod1,uprod2
5118
5119       estr=0.0d0
5120       estr1=0.0d0
5121 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5122 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5123
5124       do i=ibondp_start,ibondp_end
5125         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5126         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5127 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5128 !C          do j=1,3
5129 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5130 !C            *dc(j,i-1)/vbld(i)
5131 !C          enddo
5132 !C          if (energy_dec) write(iout,*) &
5133 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5134         diff = vbld(i)-vbldpDUM
5135         else
5136         diff = vbld(i)-vbldp0
5137         endif
5138         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5139            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5140         estr=estr+diff*diff
5141         do j=1,3
5142           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5143         enddo
5144 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5145 !        endif
5146       enddo
5147       estr=0.5d0*AKP*estr+estr1
5148       print *,"estr_bb",estr,AKP
5149 !
5150 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5151 !
5152       do i=ibond_start,ibond_end
5153         iti=iabs(itype(i,1))
5154         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5155         if (iti.ne.10 .and. iti.ne.ntyp1) then
5156           nbi=nbondterm(iti)
5157           if (nbi.eq.1) then
5158             diff=vbld(i+nres)-vbldsc0(1,iti)
5159             if (energy_dec) write (iout,*) &
5160             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5161             AKSC(1,iti),AKSC(1,iti)*diff*diff
5162             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5163             print *,"estr_sc",estr
5164             do j=1,3
5165               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5166             enddo
5167           else
5168             do j=1,nbi
5169               diff=vbld(i+nres)-vbldsc0(j,iti)
5170               ud(j)=aksc(j,iti)*diff
5171               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5172             enddo
5173             uprod=u(1)
5174             do j=2,nbi
5175               uprod=uprod*u(j)
5176             enddo
5177             usum=0.0d0
5178             usumsqder=0.0d0
5179             do j=1,nbi
5180               uprod1=1.0d0
5181               uprod2=1.0d0
5182               do k=1,nbi
5183                 if (k.ne.j) then
5184                   uprod1=uprod1*u(k)
5185                   uprod2=uprod2*u(k)*u(k)
5186                 endif
5187               enddo
5188               usum=usum+uprod1
5189               usumsqder=usumsqder+ud(j)*uprod2
5190             enddo
5191             estr=estr+uprod/usum
5192             print *,"estr_sc",estr,i
5193
5194              if (energy_dec) write (iout,*) &
5195             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5196             AKSC(1,iti),AKSC(1,iti)*diff*diff
5197             do j=1,3
5198              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5199             enddo
5200           endif
5201         endif
5202       enddo
5203       return
5204       end subroutine ebond
5205 #ifdef CRYST_THETA
5206 !-----------------------------------------------------------------------------
5207       subroutine ebend(etheta)
5208 !
5209 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5210 ! angles gamma and its derivatives in consecutive thetas and gammas.
5211 !
5212       use comm_calcthet
5213 !      implicit real*8 (a-h,o-z)
5214 !      include 'DIMENSIONS'
5215 !      include 'COMMON.LOCAL'
5216 !      include 'COMMON.GEO'
5217 !      include 'COMMON.INTERACT'
5218 !      include 'COMMON.DERIV'
5219 !      include 'COMMON.VAR'
5220 !      include 'COMMON.CHAIN'
5221 !      include 'COMMON.IOUNITS'
5222 !      include 'COMMON.NAMES'
5223 !      include 'COMMON.FFIELD'
5224 !      include 'COMMON.CONTROL'
5225 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5226 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5227 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5228 !el      integer :: it
5229 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5230 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5231 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5232 !el local variables
5233       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5234        ichir21,ichir22
5235       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5236        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5237        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5238       real(kind=8),dimension(2) :: y,z
5239
5240       delta=0.02d0*pi
5241 !      time11=dexp(-2*time)
5242 !      time12=1.0d0
5243       etheta=0.0D0
5244 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5245       do i=ithet_start,ithet_end
5246         if (itype(i-1,1).eq.ntyp1) cycle
5247 ! Zero the energy function and its derivative at 0 or pi.
5248         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5249         it=itype(i-1,1)
5250         ichir1=isign(1,itype(i-2,1))
5251         ichir2=isign(1,itype(i,1))
5252          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5253          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5254          if (itype(i-1,1).eq.10) then
5255           itype1=isign(10,itype(i-2,1))
5256           ichir11=isign(1,itype(i-2,1))
5257           ichir12=isign(1,itype(i-2,1))
5258           itype2=isign(10,itype(i,1))
5259           ichir21=isign(1,itype(i,1))
5260           ichir22=isign(1,itype(i,1))
5261          endif
5262
5263         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5264 #ifdef OSF
5265           phii=phi(i)
5266           if (phii.ne.phii) phii=150.0
5267 #else
5268           phii=phi(i)
5269 #endif
5270           y(1)=dcos(phii)
5271           y(2)=dsin(phii)
5272         else
5273           y(1)=0.0D0
5274           y(2)=0.0D0
5275         endif
5276         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5277 #ifdef OSF
5278           phii1=phi(i+1)
5279           if (phii1.ne.phii1) phii1=150.0
5280           phii1=pinorm(phii1)
5281           z(1)=cos(phii1)
5282 #else
5283           phii1=phi(i+1)
5284           z(1)=dcos(phii1)
5285 #endif
5286           z(2)=dsin(phii1)
5287         else
5288           z(1)=0.0D0
5289           z(2)=0.0D0
5290         endif
5291 ! Calculate the "mean" value of theta from the part of the distribution
5292 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5293 ! In following comments this theta will be referred to as t_c.
5294         thet_pred_mean=0.0d0
5295         do k=1,2
5296             athetk=athet(k,it,ichir1,ichir2)
5297             bthetk=bthet(k,it,ichir1,ichir2)
5298           if (it.eq.10) then
5299              athetk=athet(k,itype1,ichir11,ichir12)
5300              bthetk=bthet(k,itype2,ichir21,ichir22)
5301           endif
5302          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5303         enddo
5304         dthett=thet_pred_mean*ssd
5305         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5306 ! Derivatives of the "mean" values in gamma1 and gamma2.
5307         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5308                +athet(2,it,ichir1,ichir2)*y(1))*ss
5309         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5310                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5311          if (it.eq.10) then
5312         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5313              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5314         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5315                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5316          endif
5317         if (theta(i).gt.pi-delta) then
5318           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5319                E_tc0)
5320           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5321           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5322           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5323               E_theta)
5324           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5325               E_tc)
5326         else if (theta(i).lt.delta) then
5327           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5328           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5329           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5330               E_theta)
5331           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5332           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5333               E_tc)
5334         else
5335           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5336               E_theta,E_tc)
5337         endif
5338         etheta=etheta+ethetai
5339         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5340             'ebend',i,ethetai
5341         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5342         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5343         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5344       enddo
5345 ! Ufff.... We've done all this!!!
5346       return
5347       end subroutine ebend
5348 !-----------------------------------------------------------------------------
5349       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5350
5351       use comm_calcthet
5352 !      implicit real*8 (a-h,o-z)
5353 !      include 'DIMENSIONS'
5354 !      include 'COMMON.LOCAL'
5355 !      include 'COMMON.IOUNITS'
5356 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5357 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5358 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5359       integer :: i,j,k
5360       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5361 !el      integer :: it
5362 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5363 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5364 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5365 !el local variables
5366       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5367        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5368
5369 ! Calculate the contributions to both Gaussian lobes.
5370 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5371 ! The "polynomial part" of the "standard deviation" of this part of
5372 ! the distribution.
5373         sig=polthet(3,it)
5374         do j=2,0,-1
5375           sig=sig*thet_pred_mean+polthet(j,it)
5376         enddo
5377 ! Derivative of the "interior part" of the "standard deviation of the"
5378 ! gamma-dependent Gaussian lobe in t_c.
5379         sigtc=3*polthet(3,it)
5380         do j=2,1,-1
5381           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5382         enddo
5383         sigtc=sig*sigtc
5384 ! Set the parameters of both Gaussian lobes of the distribution.
5385 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5386         fac=sig*sig+sigc0(it)
5387         sigcsq=fac+fac
5388         sigc=1.0D0/sigcsq
5389 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5390         sigsqtc=-4.0D0*sigcsq*sigtc
5391 !       print *,i,sig,sigtc,sigsqtc
5392 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5393         sigtc=-sigtc/(fac*fac)
5394 ! Following variable is sigma(t_c)**(-2)
5395         sigcsq=sigcsq*sigcsq
5396         sig0i=sig0(it)
5397         sig0inv=1.0D0/sig0i**2
5398         delthec=thetai-thet_pred_mean
5399         delthe0=thetai-theta0i
5400         term1=-0.5D0*sigcsq*delthec*delthec
5401         term2=-0.5D0*sig0inv*delthe0*delthe0
5402 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5403 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5404 ! to the energy (this being the log of the distribution) at the end of energy
5405 ! term evaluation for this virtual-bond angle.
5406         if (term1.gt.term2) then
5407           termm=term1
5408           term2=dexp(term2-termm)
5409           term1=1.0d0
5410         else
5411           termm=term2
5412           term1=dexp(term1-termm)
5413           term2=1.0d0
5414         endif
5415 ! The ratio between the gamma-independent and gamma-dependent lobes of
5416 ! the distribution is a Gaussian function of thet_pred_mean too.
5417         diffak=gthet(2,it)-thet_pred_mean
5418         ratak=diffak/gthet(3,it)**2
5419         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5420 ! Let's differentiate it in thet_pred_mean NOW.
5421         aktc=ak*ratak
5422 ! Now put together the distribution terms to make complete distribution.
5423         termexp=term1+ak*term2
5424         termpre=sigc+ak*sig0i
5425 ! Contribution of the bending energy from this theta is just the -log of
5426 ! the sum of the contributions from the two lobes and the pre-exponential
5427 ! factor. Simple enough, isn't it?
5428         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5429 ! NOW the derivatives!!!
5430 ! 6/6/97 Take into account the deformation.
5431         E_theta=(delthec*sigcsq*term1 &
5432              +ak*delthe0*sig0inv*term2)/termexp
5433         E_tc=((sigtc+aktc*sig0i)/termpre &
5434             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5435              aktc*term2)/termexp)
5436       return
5437       end subroutine theteng
5438 #else
5439 !-----------------------------------------------------------------------------
5440       subroutine ebend(etheta,ethetacnstr)
5441 !
5442 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5443 ! angles gamma and its derivatives in consecutive thetas and gammas.
5444 ! ab initio-derived potentials from
5445 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5446 !
5447 !      implicit real*8 (a-h,o-z)
5448 !      include 'DIMENSIONS'
5449 !      include 'COMMON.LOCAL'
5450 !      include 'COMMON.GEO'
5451 !      include 'COMMON.INTERACT'
5452 !      include 'COMMON.DERIV'
5453 !      include 'COMMON.VAR'
5454 !      include 'COMMON.CHAIN'
5455 !      include 'COMMON.IOUNITS'
5456 !      include 'COMMON.NAMES'
5457 !      include 'COMMON.FFIELD'
5458 !      include 'COMMON.CONTROL'
5459       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5460       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5461       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5462       logical :: lprn=.false., lprn1=.false.
5463 !el local variables
5464       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5465       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5466       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5467 ! local variables for constrains
5468       real(kind=8) :: difi,thetiii
5469        integer itheta
5470
5471       etheta=0.0D0
5472       do i=ithet_start,ithet_end
5473         if (itype(i-1,1).eq.ntyp1) cycle
5474         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5475         if (iabs(itype(i+1,1)).eq.20) iblock=2
5476         if (iabs(itype(i+1,1)).ne.20) iblock=1
5477         dethetai=0.0d0
5478         dephii=0.0d0
5479         dephii1=0.0d0
5480         theti2=0.5d0*theta(i)
5481         ityp2=ithetyp((itype(i-1,1)))
5482         do k=1,nntheterm
5483           coskt(k)=dcos(k*theti2)
5484           sinkt(k)=dsin(k*theti2)
5485         enddo
5486         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5487 #ifdef OSF
5488           phii=phi(i)
5489           if (phii.ne.phii) phii=150.0
5490 #else
5491           phii=phi(i)
5492 #endif
5493           ityp1=ithetyp((itype(i-2,1)))
5494 ! propagation of chirality for glycine type
5495           do k=1,nsingle
5496             cosph1(k)=dcos(k*phii)
5497             sinph1(k)=dsin(k*phii)
5498           enddo
5499         else
5500           phii=0.0d0
5501           ityp1=ithetyp(itype(i-2,1))
5502           do k=1,nsingle
5503             cosph1(k)=0.0d0
5504             sinph1(k)=0.0d0
5505           enddo
5506         endif
5507         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5508 #ifdef OSF
5509           phii1=phi(i+1)
5510           if (phii1.ne.phii1) phii1=150.0
5511           phii1=pinorm(phii1)
5512 #else
5513           phii1=phi(i+1)
5514 #endif
5515           ityp3=ithetyp((itype(i,1)))
5516           do k=1,nsingle
5517             cosph2(k)=dcos(k*phii1)
5518             sinph2(k)=dsin(k*phii1)
5519           enddo
5520         else
5521           phii1=0.0d0
5522           ityp3=ithetyp(itype(i,1))
5523           do k=1,nsingle
5524             cosph2(k)=0.0d0
5525             sinph2(k)=0.0d0
5526           enddo
5527         endif
5528         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5529         do k=1,ndouble
5530           do l=1,k-1
5531             ccl=cosph1(l)*cosph2(k-l)
5532             ssl=sinph1(l)*sinph2(k-l)
5533             scl=sinph1(l)*cosph2(k-l)
5534             csl=cosph1(l)*sinph2(k-l)
5535             cosph1ph2(l,k)=ccl-ssl
5536             cosph1ph2(k,l)=ccl+ssl
5537             sinph1ph2(l,k)=scl+csl
5538             sinph1ph2(k,l)=scl-csl
5539           enddo
5540         enddo
5541         if (lprn) then
5542         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5543           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5544         write (iout,*) "coskt and sinkt"
5545         do k=1,nntheterm
5546           write (iout,*) k,coskt(k),sinkt(k)
5547         enddo
5548         endif
5549         do k=1,ntheterm
5550           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5551           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5552             *coskt(k)
5553           if (lprn) &
5554           write (iout,*) "k",k,&
5555            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5556            " ethetai",ethetai
5557         enddo
5558         if (lprn) then
5559         write (iout,*) "cosph and sinph"
5560         do k=1,nsingle
5561           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5562         enddo
5563         write (iout,*) "cosph1ph2 and sinph2ph2"
5564         do k=2,ndouble
5565           do l=1,k-1
5566             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5567                sinph1ph2(l,k),sinph1ph2(k,l)
5568           enddo
5569         enddo
5570         write(iout,*) "ethetai",ethetai
5571         endif
5572         do m=1,ntheterm2
5573           do k=1,nsingle
5574             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5575                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5576                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5577                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5578             ethetai=ethetai+sinkt(m)*aux
5579             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5580             dephii=dephii+k*sinkt(m)* &
5581                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5582                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5583             dephii1=dephii1+k*sinkt(m)* &
5584                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5585                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5586             if (lprn) &
5587             write (iout,*) "m",m," k",k," bbthet", &
5588                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5589                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5590                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5591                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5592           enddo
5593         enddo
5594         if (lprn) &
5595         write(iout,*) "ethetai",ethetai
5596         do m=1,ntheterm3
5597           do k=2,ndouble
5598             do l=1,k-1
5599               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5600                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5601                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5602                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5603               ethetai=ethetai+sinkt(m)*aux
5604               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5605               dephii=dephii+l*sinkt(m)* &
5606                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5607                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5608                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5609                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5610               dephii1=dephii1+(k-l)*sinkt(m)* &
5611                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5612                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5613                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5614                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5615               if (lprn) then
5616               write (iout,*) "m",m," k",k," l",l," ffthet",&
5617                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5618                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5619                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5620                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5621                   " ethetai",ethetai
5622               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5623                   cosph1ph2(k,l)*sinkt(m),&
5624                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5625               endif
5626             enddo
5627           enddo
5628         enddo
5629 10      continue
5630 !        lprn1=.true.
5631         if (lprn1) &
5632           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5633          i,theta(i)*rad2deg,phii*rad2deg,&
5634          phii1*rad2deg,ethetai
5635 !        lprn1=.false.
5636         etheta=etheta+ethetai
5637         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5638                                     'ebend',i,ethetai
5639         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5640         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5641         gloc(nphi+i-2,icg)=wang*dethetai
5642       enddo
5643 !-----------thete constrains
5644 !      if (tor_mode.ne.2) then
5645       ethetacnstr=0.0d0
5646 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5647       do i=ithetaconstr_start,ithetaconstr_end
5648         itheta=itheta_constr(i)
5649         thetiii=theta(itheta)
5650         difi=pinorm(thetiii-theta_constr0(i))
5651         if (difi.gt.theta_drange(i)) then
5652           difi=difi-theta_drange(i)
5653           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5654           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5655          +for_thet_constr(i)*difi**3
5656         else if (difi.lt.-drange(i)) then
5657           difi=difi+drange(i)
5658           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5659           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5660          +for_thet_constr(i)*difi**3
5661         else
5662           difi=0.0
5663         endif
5664        if (energy_dec) then
5665         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5666          i,itheta,rad2deg*thetiii, &
5667          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5668          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5669          gloc(itheta+nphi-2,icg)
5670         endif
5671       enddo
5672 !      endif
5673
5674       return
5675       end subroutine ebend
5676 #endif
5677 #ifdef CRYST_SC
5678 !-----------------------------------------------------------------------------
5679       subroutine esc(escloc)
5680 ! Calculate the local energy of a side chain and its derivatives in the
5681 ! corresponding virtual-bond valence angles THETA and the spherical angles
5682 ! ALPHA and OMEGA.
5683 !
5684       use comm_sccalc
5685 !      implicit real*8 (a-h,o-z)
5686 !      include 'DIMENSIONS'
5687 !      include 'COMMON.GEO'
5688 !      include 'COMMON.LOCAL'
5689 !      include 'COMMON.VAR'
5690 !      include 'COMMON.INTERACT'
5691 !      include 'COMMON.DERIV'
5692 !      include 'COMMON.CHAIN'
5693 !      include 'COMMON.IOUNITS'
5694 !      include 'COMMON.NAMES'
5695 !      include 'COMMON.FFIELD'
5696 !      include 'COMMON.CONTROL'
5697       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5698          ddersc0,ddummy,xtemp,temp
5699 !el      real(kind=8) :: time11,time12,time112,theti
5700       real(kind=8) :: escloc,delta
5701 !el      integer :: it,nlobit
5702 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5703 !el local variables
5704       integer :: i,k
5705       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5706        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5707       delta=0.02d0*pi
5708       escloc=0.0D0
5709 !     write (iout,'(a)') 'ESC'
5710       do i=loc_start,loc_end
5711         it=itype(i,1)
5712         if (it.eq.ntyp1) cycle
5713         if (it.eq.10) goto 1
5714         nlobit=nlob(iabs(it))
5715 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5716 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5717         theti=theta(i+1)-pipol
5718         x(1)=dtan(theti)
5719         x(2)=alph(i)
5720         x(3)=omeg(i)
5721
5722         if (x(2).gt.pi-delta) then
5723           xtemp(1)=x(1)
5724           xtemp(2)=pi-delta
5725           xtemp(3)=x(3)
5726           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5727           xtemp(2)=pi
5728           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5729           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5730               escloci,dersc(2))
5731           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5732               ddersc0(1),dersc(1))
5733           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5734               ddersc0(3),dersc(3))
5735           xtemp(2)=pi-delta
5736           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5737           xtemp(2)=pi
5738           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5739           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5740                   dersc0(2),esclocbi,dersc02)
5741           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5742                   dersc12,dersc01)
5743           call splinthet(x(2),0.5d0*delta,ss,ssd)
5744           dersc0(1)=dersc01
5745           dersc0(2)=dersc02
5746           dersc0(3)=0.0d0
5747           do k=1,3
5748             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5749           enddo
5750           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5751 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5752 !    &             esclocbi,ss,ssd
5753           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5754 !         escloci=esclocbi
5755 !         write (iout,*) escloci
5756         else if (x(2).lt.delta) then
5757           xtemp(1)=x(1)
5758           xtemp(2)=delta
5759           xtemp(3)=x(3)
5760           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5761           xtemp(2)=0.0d0
5762           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5763           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
5764               escloci,dersc(2))
5765           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5766               ddersc0(1),dersc(1))
5767           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
5768               ddersc0(3),dersc(3))
5769           xtemp(2)=delta
5770           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5771           xtemp(2)=0.0d0
5772           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5773           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
5774                   dersc0(2),esclocbi,dersc02)
5775           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5776                   dersc12,dersc01)
5777           dersc0(1)=dersc01
5778           dersc0(2)=dersc02
5779           dersc0(3)=0.0d0
5780           call splinthet(x(2),0.5d0*delta,ss,ssd)
5781           do k=1,3
5782             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5783           enddo
5784           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5785 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5786 !    &             esclocbi,ss,ssd
5787           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5788 !         write (iout,*) escloci
5789         else
5790           call enesc(x,escloci,dersc,ddummy,.false.)
5791         endif
5792
5793         escloc=escloc+escloci
5794         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5795            'escloc',i,escloci
5796 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5797
5798         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
5799          wscloc*dersc(1)
5800         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5801         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5802     1   continue
5803       enddo
5804       return
5805       end subroutine esc
5806 !-----------------------------------------------------------------------------
5807       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5808
5809       use comm_sccalc
5810 !      implicit real*8 (a-h,o-z)
5811 !      include 'DIMENSIONS'
5812 !      include 'COMMON.GEO'
5813 !      include 'COMMON.LOCAL'
5814 !      include 'COMMON.IOUNITS'
5815 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5816       real(kind=8),dimension(3) :: x,z,dersc,ddersc
5817       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
5818       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
5819       real(kind=8) :: escloci
5820       logical :: mixed
5821 !el local variables
5822       integer :: j,iii,l,k !el,it,nlobit
5823       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
5824 !el       time11,time12,time112
5825 !       write (iout,*) 'it=',it,' nlobit=',nlobit
5826         escloc_i=0.0D0
5827         do j=1,3
5828           dersc(j)=0.0D0
5829           if (mixed) ddersc(j)=0.0d0
5830         enddo
5831         x3=x(3)
5832
5833 ! Because of periodicity of the dependence of the SC energy in omega we have
5834 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5835 ! To avoid underflows, first compute & store the exponents.
5836
5837         do iii=-1,1
5838
5839           x(3)=x3+iii*dwapi
5840
5841           do j=1,nlobit
5842             do k=1,3
5843               z(k)=x(k)-censc(k,j,it)
5844             enddo
5845             do k=1,3
5846               Axk=0.0D0
5847               do l=1,3
5848                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5849               enddo
5850               Ax(k,j,iii)=Axk
5851             enddo
5852             expfac=0.0D0
5853             do k=1,3
5854               expfac=expfac+Ax(k,j,iii)*z(k)
5855             enddo
5856             contr(j,iii)=expfac
5857           enddo ! j
5858
5859         enddo ! iii
5860
5861         x(3)=x3
5862 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5863 ! subsequent NaNs and INFs in energy calculation.
5864 ! Find the largest exponent
5865         emin=contr(1,-1)
5866         do iii=-1,1
5867           do j=1,nlobit
5868             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5869           enddo
5870         enddo
5871         emin=0.5D0*emin
5872 !d      print *,'it=',it,' emin=',emin
5873
5874 ! Compute the contribution to SC energy and derivatives
5875         do iii=-1,1
5876
5877           do j=1,nlobit
5878 #ifdef OSF
5879             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5880             if(adexp.ne.adexp) adexp=1.0
5881             expfac=dexp(adexp)
5882 #else
5883             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5884 #endif
5885 !d          print *,'j=',j,' expfac=',expfac
5886             escloc_i=escloc_i+expfac
5887             do k=1,3
5888               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5889             enddo
5890             if (mixed) then
5891               do k=1,3,2
5892                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
5893                   +gaussc(k,2,j,it))*expfac
5894               enddo
5895             endif
5896           enddo
5897
5898         enddo ! iii
5899
5900         dersc(1)=dersc(1)/cos(theti)**2
5901         ddersc(1)=ddersc(1)/cos(theti)**2
5902         ddersc(3)=ddersc(3)
5903
5904         escloci=-(dlog(escloc_i)-emin)
5905         do j=1,3
5906           dersc(j)=dersc(j)/escloc_i
5907         enddo
5908         if (mixed) then
5909           do j=1,3,2
5910             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5911           enddo
5912         endif
5913       return
5914       end subroutine enesc
5915 !-----------------------------------------------------------------------------
5916       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5917
5918       use comm_sccalc
5919 !      implicit real*8 (a-h,o-z)
5920 !      include 'DIMENSIONS'
5921 !      include 'COMMON.GEO'
5922 !      include 'COMMON.LOCAL'
5923 !      include 'COMMON.IOUNITS'
5924 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5925       real(kind=8),dimension(3) :: x,z,dersc
5926       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
5927       real(kind=8),dimension(nlobit) :: contr !(maxlob)
5928       real(kind=8) :: escloci,dersc12,emin
5929       logical :: mixed
5930 !el local varables
5931       integer :: j,k,l !el,it,nlobit
5932       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
5933
5934       escloc_i=0.0D0
5935
5936       do j=1,3
5937         dersc(j)=0.0D0
5938       enddo
5939
5940       do j=1,nlobit
5941         do k=1,2
5942           z(k)=x(k)-censc(k,j,it)
5943         enddo
5944         z(3)=dwapi
5945         do k=1,3
5946           Axk=0.0D0
5947           do l=1,3
5948             Axk=Axk+gaussc(l,k,j,it)*z(l)
5949           enddo
5950           Ax(k,j)=Axk
5951         enddo
5952         expfac=0.0D0
5953         do k=1,3
5954           expfac=expfac+Ax(k,j)*z(k)
5955         enddo
5956         contr(j)=expfac
5957       enddo ! j
5958
5959 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5960 ! subsequent NaNs and INFs in energy calculation.
5961 ! Find the largest exponent
5962       emin=contr(1)
5963       do j=1,nlobit
5964         if (emin.gt.contr(j)) emin=contr(j)
5965       enddo
5966       emin=0.5D0*emin
5967
5968 ! Compute the contribution to SC energy and derivatives
5969
5970       dersc12=0.0d0
5971       do j=1,nlobit
5972         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5973         escloc_i=escloc_i+expfac
5974         do k=1,2
5975           dersc(k)=dersc(k)+Ax(k,j)*expfac
5976         enddo
5977         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
5978                   +gaussc(1,2,j,it))*expfac
5979         dersc(3)=0.0d0
5980       enddo
5981
5982       dersc(1)=dersc(1)/cos(theti)**2
5983       dersc12=dersc12/cos(theti)**2
5984       escloci=-(dlog(escloc_i)-emin)
5985       do j=1,2
5986         dersc(j)=dersc(j)/escloc_i
5987       enddo
5988       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5989       return
5990       end subroutine enesc_bound
5991 #else
5992 !-----------------------------------------------------------------------------
5993       subroutine esc(escloc)
5994 ! Calculate the local energy of a side chain and its derivatives in the
5995 ! corresponding virtual-bond valence angles THETA and the spherical angles
5996 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
5997 ! added by Urszula Kozlowska. 07/11/2007
5998 !
5999       use comm_sccalc
6000 !      implicit real*8 (a-h,o-z)
6001 !      include 'DIMENSIONS'
6002 !      include 'COMMON.GEO'
6003 !      include 'COMMON.LOCAL'
6004 !      include 'COMMON.VAR'
6005 !      include 'COMMON.SCROT'
6006 !      include 'COMMON.INTERACT'
6007 !      include 'COMMON.DERIV'
6008 !      include 'COMMON.CHAIN'
6009 !      include 'COMMON.IOUNITS'
6010 !      include 'COMMON.NAMES'
6011 !      include 'COMMON.FFIELD'
6012 !      include 'COMMON.CONTROL'
6013 !      include 'COMMON.VECTORS'
6014       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6015       real(kind=8),dimension(65) :: x
6016       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6017          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6018       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6019       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6020          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6021 !el local variables
6022       integer :: i,j,k !el,it,nlobit
6023       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6024 !el      real(kind=8) :: time11,time12,time112,theti
6025 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6026       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6027                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6028                    sumene1x,sumene2x,sumene3x,sumene4x,&
6029                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6030                    cosfac2xx,sinfac2yy
6031 #ifdef DEBUG
6032       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6033                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6034                    de_dt_num
6035 #endif
6036 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6037
6038       delta=0.02d0*pi
6039       escloc=0.0D0
6040       do i=loc_start,loc_end
6041         if (itype(i,1).eq.ntyp1) cycle
6042         costtab(i+1) =dcos(theta(i+1))
6043         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6044         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6045         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6046         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6047         cosfac=dsqrt(cosfac2)
6048         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6049         sinfac=dsqrt(sinfac2)
6050         it=iabs(itype(i,1))
6051         if (it.eq.10) goto 1
6052 !
6053 !  Compute the axes of tghe local cartesian coordinates system; store in
6054 !   x_prime, y_prime and z_prime
6055 !
6056         do j=1,3
6057           x_prime(j) = 0.00
6058           y_prime(j) = 0.00
6059           z_prime(j) = 0.00
6060         enddo
6061 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6062 !     &   dc_norm(3,i+nres)
6063         do j = 1,3
6064           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6065           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6066         enddo
6067         do j = 1,3
6068           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6069         enddo
6070 !       write (2,*) "i",i
6071 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6072 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6073 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6074 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6075 !      & " xy",scalar(x_prime(1),y_prime(1)),
6076 !      & " xz",scalar(x_prime(1),z_prime(1)),
6077 !      & " yy",scalar(y_prime(1),y_prime(1)),
6078 !      & " yz",scalar(y_prime(1),z_prime(1)),
6079 !      & " zz",scalar(z_prime(1),z_prime(1))
6080 !
6081 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6082 ! to local coordinate system. Store in xx, yy, zz.
6083 !
6084         xx=0.0d0
6085         yy=0.0d0
6086         zz=0.0d0
6087         do j = 1,3
6088           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6089           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6090           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6091         enddo
6092
6093         xxtab(i)=xx
6094         yytab(i)=yy
6095         zztab(i)=zz
6096 !
6097 ! Compute the energy of the ith side cbain
6098 !
6099 !        write (2,*) "xx",xx," yy",yy," zz",zz
6100         it=iabs(itype(i,1))
6101         do j = 1,65
6102           x(j) = sc_parmin(j,it)
6103         enddo
6104 #ifdef CHECK_COORD
6105 !c diagnostics - remove later
6106         xx1 = dcos(alph(2))
6107         yy1 = dsin(alph(2))*dcos(omeg(2))
6108         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6109         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6110           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6111           xx1,yy1,zz1
6112 !,"  --- ", xx_w,yy_w,zz_w
6113 ! end diagnostics
6114 #endif
6115         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6116          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6117          + x(10)*yy*zz
6118         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6119          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6120          + x(20)*yy*zz
6121         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6122          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6123          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6124          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6125          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6126          +x(40)*xx*yy*zz
6127         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6128          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6129          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6130          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6131          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6132          +x(60)*xx*yy*zz
6133         dsc_i   = 0.743d0+x(61)
6134         dp2_i   = 1.9d0+x(62)
6135         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6136                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6137         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6138                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6139         s1=(1+x(63))/(0.1d0 + dscp1)
6140         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6141         s2=(1+x(65))/(0.1d0 + dscp2)
6142         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6143         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6144       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6145 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6146 !     &   sumene4,
6147 !     &   dscp1,dscp2,sumene
6148 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6149         escloc = escloc + sumene
6150 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6151 !     & ,zz,xx,yy
6152 !#define DEBUG
6153 #ifdef DEBUG
6154 !
6155 ! This section to check the numerical derivatives of the energy of ith side
6156 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6157 ! #define DEBUG in the code to turn it on.
6158 !
6159         write (2,*) "sumene               =",sumene
6160         aincr=1.0d-7
6161         xxsave=xx
6162         xx=xx+aincr
6163         write (2,*) xx,yy,zz
6164         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6165         de_dxx_num=(sumenep-sumene)/aincr
6166         xx=xxsave
6167         write (2,*) "xx+ sumene from enesc=",sumenep
6168         yysave=yy
6169         yy=yy+aincr
6170         write (2,*) xx,yy,zz
6171         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6172         de_dyy_num=(sumenep-sumene)/aincr
6173         yy=yysave
6174         write (2,*) "yy+ sumene from enesc=",sumenep
6175         zzsave=zz
6176         zz=zz+aincr
6177         write (2,*) xx,yy,zz
6178         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6179         de_dzz_num=(sumenep-sumene)/aincr
6180         zz=zzsave
6181         write (2,*) "zz+ sumene from enesc=",sumenep
6182         costsave=cost2tab(i+1)
6183         sintsave=sint2tab(i+1)
6184         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6185         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6186         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6187         de_dt_num=(sumenep-sumene)/aincr
6188         write (2,*) " t+ sumene from enesc=",sumenep
6189         cost2tab(i+1)=costsave
6190         sint2tab(i+1)=sintsave
6191 ! End of diagnostics section.
6192 #endif
6193 !
6194 ! Compute the gradient of esc
6195 !
6196 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6197         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6198         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6199         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6200         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6201         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6202         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6203         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6204         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6205         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6206            *(pom_s1/dscp1+pom_s16*dscp1**4)
6207         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6208            *(pom_s2/dscp2+pom_s26*dscp2**4)
6209         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6210         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6211         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6212         +x(40)*yy*zz
6213         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6214         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6215         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6216         +x(60)*yy*zz
6217         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6218               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6219               +(pom1+pom2)*pom_dx
6220 #ifdef DEBUG
6221         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6222 #endif
6223 !
6224         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6225         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6226         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6227         +x(40)*xx*zz
6228         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6229         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6230         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6231         +x(59)*zz**2 +x(60)*xx*zz
6232         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6233               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6234               +(pom1-pom2)*pom_dy
6235 #ifdef DEBUG
6236         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6237 #endif
6238 !
6239         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6240         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6241         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6242         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6243         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6244         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6245         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6246         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6247 #ifdef DEBUG
6248         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6249 #endif
6250 !
6251         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6252         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6253         +pom1*pom_dt1+pom2*pom_dt2
6254 #ifdef DEBUG
6255         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6256 #endif
6257 !
6258 !
6259        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6260        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6261        cosfac2xx=cosfac2*xx
6262        sinfac2yy=sinfac2*yy
6263        do k = 1,3
6264          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6265             vbld_inv(i+1)
6266          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6267             vbld_inv(i)
6268          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6269          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6270 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6271 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6272 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6273 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6274          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6275          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6276          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6277          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6278          dZZ_Ci1(k)=0.0d0
6279          dZZ_Ci(k)=0.0d0
6280          do j=1,3
6281            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6282            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6283            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6284            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6285          enddo
6286
6287          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6288          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6289          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6290          (z_prime(k)-zz*dC_norm(k,i+nres))
6291 !
6292          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6293          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6294        enddo
6295
6296        do k=1,3
6297          dXX_Ctab(k,i)=dXX_Ci(k)
6298          dXX_C1tab(k,i)=dXX_Ci1(k)
6299          dYY_Ctab(k,i)=dYY_Ci(k)
6300          dYY_C1tab(k,i)=dYY_Ci1(k)
6301          dZZ_Ctab(k,i)=dZZ_Ci(k)
6302          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6303          dXX_XYZtab(k,i)=dXX_XYZ(k)
6304          dYY_XYZtab(k,i)=dYY_XYZ(k)
6305          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6306        enddo
6307
6308        do k = 1,3
6309 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6310 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6311 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6312 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6313 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6314 !     &    dt_dci(k)
6315 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6316 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6317          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6318           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6319          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6320           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6321          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6322           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6323        enddo
6324 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6325 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6326
6327 ! to check gradient call subroutine check_grad
6328
6329     1 continue
6330       enddo
6331       return
6332       end subroutine esc
6333 !-----------------------------------------------------------------------------
6334       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6335 !      implicit none
6336       real(kind=8),dimension(65) :: x
6337       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6338         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6339
6340       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6341         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6342         + x(10)*yy*zz
6343       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6344         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6345         + x(20)*yy*zz
6346       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6347         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6348         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6349         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6350         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6351         +x(40)*xx*yy*zz
6352       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6353         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6354         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6355         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6356         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6357         +x(60)*xx*yy*zz
6358       dsc_i   = 0.743d0+x(61)
6359       dp2_i   = 1.9d0+x(62)
6360       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6361                 *(xx*cost2+yy*sint2))
6362       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6363                 *(xx*cost2-yy*sint2))
6364       s1=(1+x(63))/(0.1d0 + dscp1)
6365       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6366       s2=(1+x(65))/(0.1d0 + dscp2)
6367       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6368       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6369        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6370       enesc=sumene
6371       return
6372       end function enesc
6373 #endif
6374 !-----------------------------------------------------------------------------
6375       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6376 !
6377 ! This procedure calculates two-body contact function g(rij) and its derivative:
6378 !
6379 !           eps0ij                                     !       x < -1
6380 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6381 !            0                                         !       x > 1
6382 !
6383 ! where x=(rij-r0ij)/delta
6384 !
6385 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6386 !
6387 !      implicit none
6388       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6389       real(kind=8) :: x,x2,x4,delta
6390 !     delta=0.02D0*r0ij
6391 !      delta=0.2D0*r0ij
6392       x=(rij-r0ij)/delta
6393       if (x.lt.-1.0D0) then
6394         fcont=eps0ij
6395         fprimcont=0.0D0
6396       else if (x.le.1.0D0) then
6397         x2=x*x
6398         x4=x2*x2
6399         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6400         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6401       else
6402         fcont=0.0D0
6403         fprimcont=0.0D0
6404       endif
6405       return
6406       end subroutine gcont
6407 !-----------------------------------------------------------------------------
6408       subroutine splinthet(theti,delta,ss,ssder)
6409 !      implicit real*8 (a-h,o-z)
6410 !      include 'DIMENSIONS'
6411 !      include 'COMMON.VAR'
6412 !      include 'COMMON.GEO'
6413       real(kind=8) :: theti,delta,ss,ssder
6414       real(kind=8) :: thetup,thetlow
6415       thetup=pi-delta
6416       thetlow=delta
6417       if (theti.gt.pipol) then
6418         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6419       else
6420         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6421         ssder=-ssder
6422       endif
6423       return
6424       end subroutine splinthet
6425 !-----------------------------------------------------------------------------
6426       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6427 !      implicit none
6428       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6429       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6430       a1=fprim0*delta/(f1-f0)
6431       a2=3.0d0-2.0d0*a1
6432       a3=a1-2.0d0
6433       ksi=(x-x0)/delta
6434       ksi2=ksi*ksi
6435       ksi3=ksi2*ksi
6436       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6437       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6438       return
6439       end subroutine spline1
6440 !-----------------------------------------------------------------------------
6441       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6442 !      implicit none
6443       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6444       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6445       ksi=(x-x0)/delta
6446       ksi2=ksi*ksi
6447       ksi3=ksi2*ksi
6448       a1=fprim0x*delta
6449       a2=3*(f1x-f0x)-2*fprim0x*delta
6450       a3=fprim0x*delta-2*(f1x-f0x)
6451       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6452       return
6453       end subroutine spline2
6454 !-----------------------------------------------------------------------------
6455 #ifdef CRYST_TOR
6456 !-----------------------------------------------------------------------------
6457       subroutine etor(etors,edihcnstr)
6458 !      implicit real*8 (a-h,o-z)
6459 !      include 'DIMENSIONS'
6460 !      include 'COMMON.VAR'
6461 !      include 'COMMON.GEO'
6462 !      include 'COMMON.LOCAL'
6463 !      include 'COMMON.TORSION'
6464 !      include 'COMMON.INTERACT'
6465 !      include 'COMMON.DERIV'
6466 !      include 'COMMON.CHAIN'
6467 !      include 'COMMON.NAMES'
6468 !      include 'COMMON.IOUNITS'
6469 !      include 'COMMON.FFIELD'
6470 !      include 'COMMON.TORCNSTR'
6471 !      include 'COMMON.CONTROL'
6472       real(kind=8) :: etors,edihcnstr
6473       logical :: lprn
6474 !el local variables
6475       integer :: i,j,
6476       real(kind=8) :: phii,fac,etors_ii
6477
6478 ! Set lprn=.true. for debugging
6479       lprn=.false.
6480 !      lprn=.true.
6481       etors=0.0D0
6482       do i=iphi_start,iphi_end
6483       etors_ii=0.0D0
6484         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6485             .or. itype(i,1).eq.ntyp1) cycle
6486         itori=itortyp(itype(i-2,1))
6487         itori1=itortyp(itype(i-1,1))
6488         phii=phi(i)
6489         gloci=0.0D0
6490 ! Proline-Proline pair is a special case...
6491         if (itori.eq.3 .and. itori1.eq.3) then
6492           if (phii.gt.-dwapi3) then
6493             cosphi=dcos(3*phii)
6494             fac=1.0D0/(1.0D0-cosphi)
6495             etorsi=v1(1,3,3)*fac
6496             etorsi=etorsi+etorsi
6497             etors=etors+etorsi-v1(1,3,3)
6498             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6499             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6500           endif
6501           do j=1,3
6502             v1ij=v1(j+1,itori,itori1)
6503             v2ij=v2(j+1,itori,itori1)
6504             cosphi=dcos(j*phii)
6505             sinphi=dsin(j*phii)
6506             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6507             if (energy_dec) etors_ii=etors_ii+ &
6508                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6509             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6510           enddo
6511         else
6512           do j=1,nterm_old
6513             v1ij=v1(j,itori,itori1)
6514             v2ij=v2(j,itori,itori1)
6515             cosphi=dcos(j*phii)
6516             sinphi=dsin(j*phii)
6517             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6518             if (energy_dec) etors_ii=etors_ii+ &
6519                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6520             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6521           enddo
6522         endif
6523         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6524              'etor',i,etors_ii
6525         if (lprn) &
6526         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6527         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6528         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6529         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6530 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6531       enddo
6532 ! 6/20/98 - dihedral angle constraints
6533       edihcnstr=0.0d0
6534       do i=1,ndih_constr
6535         itori=idih_constr(i)
6536         phii=phi(itori)
6537         difi=phii-phi0(i)
6538         if (difi.gt.drange(i)) then
6539           difi=difi-drange(i)
6540           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6541           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6542         else if (difi.lt.-drange(i)) then
6543           difi=difi+drange(i)
6544           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6545           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6546         endif
6547 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6548 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6549       enddo
6550 !      write (iout,*) 'edihcnstr',edihcnstr
6551       return
6552       end subroutine etor
6553 !-----------------------------------------------------------------------------
6554       subroutine etor_d(etors_d)
6555       real(kind=8) :: etors_d
6556       etors_d=0.0d0
6557       return
6558       end subroutine etor_d
6559 #else
6560 !-----------------------------------------------------------------------------
6561       subroutine etor(etors,edihcnstr)
6562 !      implicit real*8 (a-h,o-z)
6563 !      include 'DIMENSIONS'
6564 !      include 'COMMON.VAR'
6565 !      include 'COMMON.GEO'
6566 !      include 'COMMON.LOCAL'
6567 !      include 'COMMON.TORSION'
6568 !      include 'COMMON.INTERACT'
6569 !      include 'COMMON.DERIV'
6570 !      include 'COMMON.CHAIN'
6571 !      include 'COMMON.NAMES'
6572 !      include 'COMMON.IOUNITS'
6573 !      include 'COMMON.FFIELD'
6574 !      include 'COMMON.TORCNSTR'
6575 !      include 'COMMON.CONTROL'
6576       real(kind=8) :: etors,edihcnstr
6577       logical :: lprn
6578 !el local variables
6579       integer :: i,j,iblock,itori,itori1
6580       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6581                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6582 ! Set lprn=.true. for debugging
6583       lprn=.false.
6584 !     lprn=.true.
6585       etors=0.0D0
6586       do i=iphi_start,iphi_end
6587         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6588              .or. itype(i-3,1).eq.ntyp1 &
6589              .or. itype(i,1).eq.ntyp1) cycle
6590         etors_ii=0.0D0
6591          if (iabs(itype(i,1)).eq.20) then
6592          iblock=2
6593          else
6594          iblock=1
6595          endif
6596         itori=itortyp(itype(i-2,1))
6597         itori1=itortyp(itype(i-1,1))
6598         phii=phi(i)
6599         gloci=0.0D0
6600 ! Regular cosine and sine terms
6601         do j=1,nterm(itori,itori1,iblock)
6602           v1ij=v1(j,itori,itori1,iblock)
6603           v2ij=v2(j,itori,itori1,iblock)
6604           cosphi=dcos(j*phii)
6605           sinphi=dsin(j*phii)
6606           etors=etors+v1ij*cosphi+v2ij*sinphi
6607           if (energy_dec) etors_ii=etors_ii+ &
6608                      v1ij*cosphi+v2ij*sinphi
6609           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6610         enddo
6611 ! Lorentz terms
6612 !                         v1
6613 !  E = SUM ----------------------------------- - v1
6614 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6615 !
6616         cosphi=dcos(0.5d0*phii)
6617         sinphi=dsin(0.5d0*phii)
6618         do j=1,nlor(itori,itori1,iblock)
6619           vl1ij=vlor1(j,itori,itori1)
6620           vl2ij=vlor2(j,itori,itori1)
6621           vl3ij=vlor3(j,itori,itori1)
6622           pom=vl2ij*cosphi+vl3ij*sinphi
6623           pom1=1.0d0/(pom*pom+1.0d0)
6624           etors=etors+vl1ij*pom1
6625           if (energy_dec) etors_ii=etors_ii+ &
6626                      vl1ij*pom1
6627           pom=-pom*pom1*pom1
6628           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6629         enddo
6630 ! Subtract the constant term
6631         etors=etors-v0(itori,itori1,iblock)
6632           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6633                'etor',i,etors_ii-v0(itori,itori1,iblock)
6634         if (lprn) &
6635         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6636         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6637         (v1(j,itori,itori1,iblock),j=1,6),&
6638         (v2(j,itori,itori1,iblock),j=1,6)
6639         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6640 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6641       enddo
6642 ! 6/20/98 - dihedral angle constraints
6643       edihcnstr=0.0d0
6644 !      do i=1,ndih_constr
6645       do i=idihconstr_start,idihconstr_end
6646         itori=idih_constr(i)
6647         phii=phi(itori)
6648         difi=pinorm(phii-phi0(i))
6649         if (difi.gt.drange(i)) then
6650           difi=difi-drange(i)
6651           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6652           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6653         else if (difi.lt.-drange(i)) then
6654           difi=difi+drange(i)
6655           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6656           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6657         else
6658           difi=0.0
6659         endif
6660 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6661 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6662 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6663       enddo
6664 !d       write (iout,*) 'edihcnstr',edihcnstr
6665       return
6666       end subroutine etor
6667 !-----------------------------------------------------------------------------
6668       subroutine etor_d(etors_d)
6669 ! 6/23/01 Compute double torsional energy
6670 !      implicit real*8 (a-h,o-z)
6671 !      include 'DIMENSIONS'
6672 !      include 'COMMON.VAR'
6673 !      include 'COMMON.GEO'
6674 !      include 'COMMON.LOCAL'
6675 !      include 'COMMON.TORSION'
6676 !      include 'COMMON.INTERACT'
6677 !      include 'COMMON.DERIV'
6678 !      include 'COMMON.CHAIN'
6679 !      include 'COMMON.NAMES'
6680 !      include 'COMMON.IOUNITS'
6681 !      include 'COMMON.FFIELD'
6682 !      include 'COMMON.TORCNSTR'
6683       real(kind=8) :: etors_d,etors_d_ii
6684       logical :: lprn
6685 !el local variables
6686       integer :: i,j,k,l,itori,itori1,itori2,iblock
6687       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6688                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6689                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6690                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6691 ! Set lprn=.true. for debugging
6692       lprn=.false.
6693 !     lprn=.true.
6694       etors_d=0.0D0
6695 !      write(iout,*) "a tu??"
6696       do i=iphid_start,iphid_end
6697         etors_d_ii=0.0D0
6698         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6699             .or. itype(i-3,1).eq.ntyp1 &
6700             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6701         itori=itortyp(itype(i-2,1))
6702         itori1=itortyp(itype(i-1,1))
6703         itori2=itortyp(itype(i,1))
6704         phii=phi(i)
6705         phii1=phi(i+1)
6706         gloci1=0.0D0
6707         gloci2=0.0D0
6708         iblock=1
6709         if (iabs(itype(i+1,1)).eq.20) iblock=2
6710
6711 ! Regular cosine and sine terms
6712         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6713           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6714           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6715           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6716           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6717           cosphi1=dcos(j*phii)
6718           sinphi1=dsin(j*phii)
6719           cosphi2=dcos(j*phii1)
6720           sinphi2=dsin(j*phii1)
6721           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6722            v2cij*cosphi2+v2sij*sinphi2
6723           if (energy_dec) etors_d_ii=etors_d_ii+ &
6724            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6725           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6726           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6727         enddo
6728         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6729           do l=1,k-1
6730             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6731             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6732             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6733             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6734             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6735             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6736             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6737             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6738             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6739               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6740             if (energy_dec) etors_d_ii=etors_d_ii+ &
6741               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6742               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6743             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6744               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6745             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6746               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6747           enddo
6748         enddo
6749         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6750                             'etor_d',i,etors_d_ii
6751         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6752         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6753       enddo
6754       return
6755       end subroutine etor_d
6756 #endif
6757 !-----------------------------------------------------------------------------
6758       subroutine eback_sc_corr(esccor)
6759 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
6760 !        conformational states; temporarily implemented as differences
6761 !        between UNRES torsional potentials (dependent on three types of
6762 !        residues) and the torsional potentials dependent on all 20 types
6763 !        of residues computed from AM1  energy surfaces of terminally-blocked
6764 !        amino-acid residues.
6765 !      implicit real*8 (a-h,o-z)
6766 !      include 'DIMENSIONS'
6767 !      include 'COMMON.VAR'
6768 !      include 'COMMON.GEO'
6769 !      include 'COMMON.LOCAL'
6770 !      include 'COMMON.TORSION'
6771 !      include 'COMMON.SCCOR'
6772 !      include 'COMMON.INTERACT'
6773 !      include 'COMMON.DERIV'
6774 !      include 'COMMON.CHAIN'
6775 !      include 'COMMON.NAMES'
6776 !      include 'COMMON.IOUNITS'
6777 !      include 'COMMON.FFIELD'
6778 !      include 'COMMON.CONTROL'
6779       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
6780                    cosphi,sinphi
6781       logical :: lprn
6782       integer :: i,interty,j,isccori,isccori1,intertyp
6783 ! Set lprn=.true. for debugging
6784       lprn=.false.
6785 !      lprn=.true.
6786 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6787       esccor=0.0D0
6788       do i=itau_start,itau_end
6789         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
6790         esccor_ii=0.0D0
6791         isccori=isccortyp(itype(i-2,1))
6792         isccori1=isccortyp(itype(i-1,1))
6793
6794 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6795         phii=phi(i)
6796         do intertyp=1,3 !intertyp
6797          esccor_ii=0.0D0
6798 !c Added 09 May 2012 (Adasko)
6799 !c  Intertyp means interaction type of backbone mainchain correlation:
6800 !   1 = SC...Ca...Ca...Ca
6801 !   2 = Ca...Ca...Ca...SC
6802 !   3 = SC...Ca...Ca...SCi
6803         gloci=0.0D0
6804         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
6805             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
6806             (itype(i-1,1).eq.ntyp1))) &
6807           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
6808            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
6809            .or.(itype(i,1).eq.ntyp1))) &
6810           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
6811             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
6812             (itype(i-3,1).eq.ntyp1)))) cycle
6813         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
6814         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
6815        cycle
6816        do j=1,nterm_sccor(isccori,isccori1)
6817           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6818           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6819           cosphi=dcos(j*tauangle(intertyp,i))
6820           sinphi=dsin(j*tauangle(intertyp,i))
6821           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6822           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6823           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6824         enddo
6825         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
6826                                 'esccor',i,intertyp,esccor_ii
6827 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6828         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6829         if (lprn) &
6830         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6831         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
6832         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
6833         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6834         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6835        enddo !intertyp
6836       enddo
6837
6838       return
6839       end subroutine eback_sc_corr
6840 !-----------------------------------------------------------------------------
6841       subroutine multibody(ecorr)
6842 ! This subroutine calculates multi-body contributions to energy following
6843 ! the idea of Skolnick et al. If side chains I and J make a contact and
6844 ! at the same time side chains I+1 and J+1 make a contact, an extra
6845 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6846 !      implicit real*8 (a-h,o-z)
6847 !      include 'DIMENSIONS'
6848 !      include 'COMMON.IOUNITS'
6849 !      include 'COMMON.DERIV'
6850 !      include 'COMMON.INTERACT'
6851 !      include 'COMMON.CONTACTS'
6852       real(kind=8),dimension(3) :: gx,gx1
6853       logical :: lprn
6854       real(kind=8) :: ecorr
6855       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
6856 ! Set lprn=.true. for debugging
6857       lprn=.false.
6858
6859       if (lprn) then
6860         write (iout,'(a)') 'Contact function values:'
6861         do i=nnt,nct-2
6862           write (iout,'(i2,20(1x,i2,f10.5))') &
6863               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6864         enddo
6865       endif
6866       ecorr=0.0D0
6867
6868 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6869 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6870       do i=nnt,nct
6871         do j=1,3
6872           gradcorr(j,i)=0.0D0
6873           gradxorr(j,i)=0.0D0
6874         enddo
6875       enddo
6876       do i=nnt,nct-2
6877
6878         DO ISHIFT = 3,4
6879
6880         i1=i+ishift
6881         num_conti=num_cont(i)
6882         num_conti1=num_cont(i1)
6883         do jj=1,num_conti
6884           j=jcont(jj,i)
6885           do kk=1,num_conti1
6886             j1=jcont(kk,i1)
6887             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6888 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6889 !d   &                   ' ishift=',ishift
6890 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6891 ! The system gains extra energy.
6892               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6893             endif   ! j1==j+-ishift
6894           enddo     ! kk
6895         enddo       ! jj
6896
6897         ENDDO ! ISHIFT
6898
6899       enddo         ! i
6900       return
6901       end subroutine multibody
6902 !-----------------------------------------------------------------------------
6903       real(kind=8) function esccorr(i,j,k,l,jj,kk)
6904 !      implicit real*8 (a-h,o-z)
6905 !      include 'DIMENSIONS'
6906 !      include 'COMMON.IOUNITS'
6907 !      include 'COMMON.DERIV'
6908 !      include 'COMMON.INTERACT'
6909 !      include 'COMMON.CONTACTS'
6910       real(kind=8),dimension(3) :: gx,gx1
6911       logical :: lprn
6912       integer :: i,j,k,l,jj,kk,m,ll
6913       real(kind=8) :: eij,ekl
6914       lprn=.false.
6915       eij=facont(jj,i)
6916       ekl=facont(kk,k)
6917 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6918 ! Calculate the multi-body contribution to energy.
6919 ! Calculate multi-body contributions to the gradient.
6920 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6921 !d   & k,l,(gacont(m,kk,k),m=1,3)
6922       do m=1,3
6923         gx(m) =ekl*gacont(m,jj,i)
6924         gx1(m)=eij*gacont(m,kk,k)
6925         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6926         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6927         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6928         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6929       enddo
6930       do m=i,j-1
6931         do ll=1,3
6932           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6933         enddo
6934       enddo
6935       do m=k,l-1
6936         do ll=1,3
6937           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6938         enddo
6939       enddo
6940       esccorr=-eij*ekl
6941       return
6942       end function esccorr
6943 !-----------------------------------------------------------------------------
6944       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6945 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6946 !      implicit real*8 (a-h,o-z)
6947 !      include 'DIMENSIONS'
6948 !      include 'COMMON.IOUNITS'
6949 #ifdef MPI
6950       include "mpif.h"
6951 !      integer :: maxconts !max_cont=maxconts  =nres/4
6952       integer,parameter :: max_dim=26
6953       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6954       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6955 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6956 !el      common /przechowalnia/ zapas
6957       integer :: status(MPI_STATUS_SIZE)
6958       integer,dimension((nres/4)*2) :: req !maxconts*2
6959       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
6960 #endif
6961 !      include 'COMMON.SETUP'
6962 !      include 'COMMON.FFIELD'
6963 !      include 'COMMON.DERIV'
6964 !      include 'COMMON.INTERACT'
6965 !      include 'COMMON.CONTACTS'
6966 !      include 'COMMON.CONTROL'
6967 !      include 'COMMON.LOCAL'
6968       real(kind=8),dimension(3) :: gx,gx1
6969       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
6970       logical :: lprn,ldone
6971 !el local variables
6972       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
6973               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
6974
6975 ! Set lprn=.true. for debugging
6976       lprn=.false.
6977 #ifdef MPI
6978 !      maxconts=nres/4
6979       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6980       n_corr=0
6981       n_corr1=0
6982       if (nfgtasks.le.1) goto 30
6983       if (lprn) then
6984         write (iout,'(a)') 'Contact function values before RECEIVE:'
6985         do i=nnt,nct-2
6986           write (iout,'(2i3,50(1x,i2,f5.2))') &
6987           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6988           j=1,num_cont_hb(i))
6989         enddo
6990       endif
6991       call flush(iout)
6992       do i=1,ntask_cont_from
6993         ncont_recv(i)=0
6994       enddo
6995       do i=1,ntask_cont_to
6996         ncont_sent(i)=0
6997       enddo
6998 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6999 !     & ntask_cont_to
7000 ! Make the list of contacts to send to send to other procesors
7001 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7002 !      call flush(iout)
7003       do i=iturn3_start,iturn3_end
7004 !        write (iout,*) "make contact list turn3",i," num_cont",
7005 !     &    num_cont_hb(i)
7006         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7007       enddo
7008       do i=iturn4_start,iturn4_end
7009 !        write (iout,*) "make contact list turn4",i," num_cont",
7010 !     &   num_cont_hb(i)
7011         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7012       enddo
7013       do ii=1,nat_sent
7014         i=iat_sent(ii)
7015 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7016 !     &    num_cont_hb(i)
7017         do j=1,num_cont_hb(i)
7018         do k=1,4
7019           jjc=jcont_hb(j,i)
7020           iproc=iint_sent_local(k,jjc,ii)
7021 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7022           if (iproc.gt.0) then
7023             ncont_sent(iproc)=ncont_sent(iproc)+1
7024             nn=ncont_sent(iproc)
7025             zapas(1,nn,iproc)=i
7026             zapas(2,nn,iproc)=jjc
7027             zapas(3,nn,iproc)=facont_hb(j,i)
7028             zapas(4,nn,iproc)=ees0p(j,i)
7029             zapas(5,nn,iproc)=ees0m(j,i)
7030             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7031             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7032             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7033             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7034             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7035             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7036             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7037             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7038             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7039             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7040             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7041             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7042             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7043             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7044             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7045             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7046             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7047             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7048             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7049             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7050             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7051           endif
7052         enddo
7053         enddo
7054       enddo
7055       if (lprn) then
7056       write (iout,*) &
7057         "Numbers of contacts to be sent to other processors",&
7058         (ncont_sent(i),i=1,ntask_cont_to)
7059       write (iout,*) "Contacts sent"
7060       do ii=1,ntask_cont_to
7061         nn=ncont_sent(ii)
7062         iproc=itask_cont_to(ii)
7063         write (iout,*) nn," contacts to processor",iproc,&
7064          " of CONT_TO_COMM group"
7065         do i=1,nn
7066           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7067         enddo
7068       enddo
7069       call flush(iout)
7070       endif
7071       CorrelType=477
7072       CorrelID=fg_rank+1
7073       CorrelType1=478
7074       CorrelID1=nfgtasks+fg_rank+1
7075       ireq=0
7076 ! Receive the numbers of needed contacts from other processors
7077       do ii=1,ntask_cont_from
7078         iproc=itask_cont_from(ii)
7079         ireq=ireq+1
7080         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7081           FG_COMM,req(ireq),IERR)
7082       enddo
7083 !      write (iout,*) "IRECV ended"
7084 !      call flush(iout)
7085 ! Send the number of contacts needed by other processors
7086       do ii=1,ntask_cont_to
7087         iproc=itask_cont_to(ii)
7088         ireq=ireq+1
7089         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7090           FG_COMM,req(ireq),IERR)
7091       enddo
7092 !      write (iout,*) "ISEND ended"
7093 !      write (iout,*) "number of requests (nn)",ireq
7094       call flush(iout)
7095       if (ireq.gt.0) &
7096         call MPI_Waitall(ireq,req,status_array,ierr)
7097 !      write (iout,*)
7098 !     &  "Numbers of contacts to be received from other processors",
7099 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7100 !      call flush(iout)
7101 ! Receive contacts
7102       ireq=0
7103       do ii=1,ntask_cont_from
7104         iproc=itask_cont_from(ii)
7105         nn=ncont_recv(ii)
7106 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7107 !     &   " of CONT_TO_COMM group"
7108         call flush(iout)
7109         if (nn.gt.0) then
7110           ireq=ireq+1
7111           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7112           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7113 !          write (iout,*) "ireq,req",ireq,req(ireq)
7114         endif
7115       enddo
7116 ! Send the contacts to processors that need them
7117       do ii=1,ntask_cont_to
7118         iproc=itask_cont_to(ii)
7119         nn=ncont_sent(ii)
7120 !        write (iout,*) nn," contacts to processor",iproc,
7121 !     &   " of CONT_TO_COMM group"
7122         if (nn.gt.0) then
7123           ireq=ireq+1
7124           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7125             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7126 !          write (iout,*) "ireq,req",ireq,req(ireq)
7127 !          do i=1,nn
7128 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7129 !          enddo
7130         endif
7131       enddo
7132 !      write (iout,*) "number of requests (contacts)",ireq
7133 !      write (iout,*) "req",(req(i),i=1,4)
7134 !      call flush(iout)
7135       if (ireq.gt.0) &
7136        call MPI_Waitall(ireq,req,status_array,ierr)
7137       do iii=1,ntask_cont_from
7138         iproc=itask_cont_from(iii)
7139         nn=ncont_recv(iii)
7140         if (lprn) then
7141         write (iout,*) "Received",nn," contacts from processor",iproc,&
7142          " of CONT_FROM_COMM group"
7143         call flush(iout)
7144         do i=1,nn
7145           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7146         enddo
7147         call flush(iout)
7148         endif
7149         do i=1,nn
7150           ii=zapas_recv(1,i,iii)
7151 ! Flag the received contacts to prevent double-counting
7152           jj=-zapas_recv(2,i,iii)
7153 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7154 !          call flush(iout)
7155           nnn=num_cont_hb(ii)+1
7156           num_cont_hb(ii)=nnn
7157           jcont_hb(nnn,ii)=jj
7158           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7159           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7160           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7161           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7162           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7163           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7164           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7165           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7166           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7167           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7168           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7169           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7170           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7171           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7172           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7173           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7174           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7175           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7176           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7177           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7178           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7179           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7180           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7181           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7182         enddo
7183       enddo
7184       call flush(iout)
7185       if (lprn) then
7186         write (iout,'(a)') 'Contact function values after receive:'
7187         do i=nnt,nct-2
7188           write (iout,'(2i3,50(1x,i3,f5.2))') &
7189           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7190           j=1,num_cont_hb(i))
7191         enddo
7192         call flush(iout)
7193       endif
7194    30 continue
7195 #endif
7196       if (lprn) then
7197         write (iout,'(a)') 'Contact function values:'
7198         do i=nnt,nct-2
7199           write (iout,'(2i3,50(1x,i3,f5.2))') &
7200           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7201           j=1,num_cont_hb(i))
7202         enddo
7203       endif
7204       ecorr=0.0D0
7205
7206 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7207 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7208 ! Remove the loop below after debugging !!!
7209       do i=nnt,nct
7210         do j=1,3
7211           gradcorr(j,i)=0.0D0
7212           gradxorr(j,i)=0.0D0
7213         enddo
7214       enddo
7215 ! Calculate the local-electrostatic correlation terms
7216       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7217         i1=i+1
7218         num_conti=num_cont_hb(i)
7219         num_conti1=num_cont_hb(i+1)
7220         do jj=1,num_conti
7221           j=jcont_hb(jj,i)
7222           jp=iabs(j)
7223           do kk=1,num_conti1
7224             j1=jcont_hb(kk,i1)
7225             jp1=iabs(j1)
7226 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7227 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7228             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7229                 .or. j.lt.0 .and. j1.gt.0) .and. &
7230                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7231 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7232 ! The system gains extra energy.
7233               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7234               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7235                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7236               n_corr=n_corr+1
7237             else if (j1.eq.j) then
7238 ! Contacts I-J and I-(J+1) occur simultaneously.
7239 ! The system loses extra energy.
7240 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7241             endif
7242           enddo ! kk
7243           do kk=1,num_conti
7244             j1=jcont_hb(kk,i)
7245 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7246 !    &         ' jj=',jj,' kk=',kk
7247             if (j1.eq.j+1) then
7248 ! Contacts I-J and (I+1)-J occur simultaneously.
7249 ! The system loses extra energy.
7250 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7251             endif ! j1==j+1
7252           enddo ! kk
7253         enddo ! jj
7254       enddo ! i
7255       return
7256       end subroutine multibody_hb
7257 !-----------------------------------------------------------------------------
7258       subroutine add_hb_contact(ii,jj,itask)
7259 !      implicit real*8 (a-h,o-z)
7260 !      include "DIMENSIONS"
7261 !      include "COMMON.IOUNITS"
7262 !      include "COMMON.CONTACTS"
7263 !      integer,parameter :: maxconts=nres/4
7264       integer,parameter :: max_dim=26
7265       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7266 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7267 !      common /przechowalnia/ zapas
7268       integer :: i,j,ii,jj,iproc,nn,jjc
7269       integer,dimension(4) :: itask
7270 !      write (iout,*) "itask",itask
7271       do i=1,2
7272         iproc=itask(i)
7273         if (iproc.gt.0) then
7274           do j=1,num_cont_hb(ii)
7275             jjc=jcont_hb(j,ii)
7276 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7277             if (jjc.eq.jj) then
7278               ncont_sent(iproc)=ncont_sent(iproc)+1
7279               nn=ncont_sent(iproc)
7280               zapas(1,nn,iproc)=ii
7281               zapas(2,nn,iproc)=jjc
7282               zapas(3,nn,iproc)=facont_hb(j,ii)
7283               zapas(4,nn,iproc)=ees0p(j,ii)
7284               zapas(5,nn,iproc)=ees0m(j,ii)
7285               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7286               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7287               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7288               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7289               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7290               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7291               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7292               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7293               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7294               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7295               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7296               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7297               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7298               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7299               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7300               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7301               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7302               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7303               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7304               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7305               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7306               exit
7307             endif
7308           enddo
7309         endif
7310       enddo
7311       return
7312       end subroutine add_hb_contact
7313 !-----------------------------------------------------------------------------
7314       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7315 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7316 !      implicit real*8 (a-h,o-z)
7317 !      include 'DIMENSIONS'
7318 !      include 'COMMON.IOUNITS'
7319       integer,parameter :: max_dim=70
7320 #ifdef MPI
7321       include "mpif.h"
7322 !      integer :: maxconts !max_cont=maxconts=nres/4
7323       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7324       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7325 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7326 !      common /przechowalnia/ zapas
7327       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7328         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7329         ierr,iii,nnn
7330 #endif
7331 !      include 'COMMON.SETUP'
7332 !      include 'COMMON.FFIELD'
7333 !      include 'COMMON.DERIV'
7334 !      include 'COMMON.LOCAL'
7335 !      include 'COMMON.INTERACT'
7336 !      include 'COMMON.CONTACTS'
7337 !      include 'COMMON.CHAIN'
7338 !      include 'COMMON.CONTROL'
7339       real(kind=8),dimension(3) :: gx,gx1
7340       integer,dimension(nres) :: num_cont_hb_old
7341       logical :: lprn,ldone
7342 !EL      double precision eello4,eello5,eelo6,eello_turn6
7343 !EL      external eello4,eello5,eello6,eello_turn6
7344 !el local variables
7345       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7346               j1,jp1,i1,num_conti1
7347       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7348       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7349
7350 ! Set lprn=.true. for debugging
7351       lprn=.false.
7352       eturn6=0.0d0
7353 #ifdef MPI
7354 !      maxconts=nres/4
7355       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7356       do i=1,nres
7357         num_cont_hb_old(i)=num_cont_hb(i)
7358       enddo
7359       n_corr=0
7360       n_corr1=0
7361       if (nfgtasks.le.1) goto 30
7362       if (lprn) then
7363         write (iout,'(a)') 'Contact function values before RECEIVE:'
7364         do i=nnt,nct-2
7365           write (iout,'(2i3,50(1x,i2,f5.2))') &
7366           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7367           j=1,num_cont_hb(i))
7368         enddo
7369       endif
7370       call flush(iout)
7371       do i=1,ntask_cont_from
7372         ncont_recv(i)=0
7373       enddo
7374       do i=1,ntask_cont_to
7375         ncont_sent(i)=0
7376       enddo
7377 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7378 !     & ntask_cont_to
7379 ! Make the list of contacts to send to send to other procesors
7380       do i=iturn3_start,iturn3_end
7381 !        write (iout,*) "make contact list turn3",i," num_cont",
7382 !     &    num_cont_hb(i)
7383         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7384       enddo
7385       do i=iturn4_start,iturn4_end
7386 !        write (iout,*) "make contact list turn4",i," num_cont",
7387 !     &   num_cont_hb(i)
7388         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7389       enddo
7390       do ii=1,nat_sent
7391         i=iat_sent(ii)
7392 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7393 !     &    num_cont_hb(i)
7394         do j=1,num_cont_hb(i)
7395         do k=1,4
7396           jjc=jcont_hb(j,i)
7397           iproc=iint_sent_local(k,jjc,ii)
7398 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7399           if (iproc.ne.0) then
7400             ncont_sent(iproc)=ncont_sent(iproc)+1
7401             nn=ncont_sent(iproc)
7402             zapas(1,nn,iproc)=i
7403             zapas(2,nn,iproc)=jjc
7404             zapas(3,nn,iproc)=d_cont(j,i)
7405             ind=3
7406             do kk=1,3
7407               ind=ind+1
7408               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7409             enddo
7410             do kk=1,2
7411               do ll=1,2
7412                 ind=ind+1
7413                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7414               enddo
7415             enddo
7416             do jj=1,5
7417               do kk=1,3
7418                 do ll=1,2
7419                   do mm=1,2
7420                     ind=ind+1
7421                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7422                   enddo
7423                 enddo
7424               enddo
7425             enddo
7426           endif
7427         enddo
7428         enddo
7429       enddo
7430       if (lprn) then
7431       write (iout,*) &
7432         "Numbers of contacts to be sent to other processors",&
7433         (ncont_sent(i),i=1,ntask_cont_to)
7434       write (iout,*) "Contacts sent"
7435       do ii=1,ntask_cont_to
7436         nn=ncont_sent(ii)
7437         iproc=itask_cont_to(ii)
7438         write (iout,*) nn," contacts to processor",iproc,&
7439          " of CONT_TO_COMM group"
7440         do i=1,nn
7441           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7442         enddo
7443       enddo
7444       call flush(iout)
7445       endif
7446       CorrelType=477
7447       CorrelID=fg_rank+1
7448       CorrelType1=478
7449       CorrelID1=nfgtasks+fg_rank+1
7450       ireq=0
7451 ! Receive the numbers of needed contacts from other processors
7452       do ii=1,ntask_cont_from
7453         iproc=itask_cont_from(ii)
7454         ireq=ireq+1
7455         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7456           FG_COMM,req(ireq),IERR)
7457       enddo
7458 !      write (iout,*) "IRECV ended"
7459 !      call flush(iout)
7460 ! Send the number of contacts needed by other processors
7461       do ii=1,ntask_cont_to
7462         iproc=itask_cont_to(ii)
7463         ireq=ireq+1
7464         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7465           FG_COMM,req(ireq),IERR)
7466       enddo
7467 !      write (iout,*) "ISEND ended"
7468 !      write (iout,*) "number of requests (nn)",ireq
7469       call flush(iout)
7470       if (ireq.gt.0) &
7471         call MPI_Waitall(ireq,req,status_array,ierr)
7472 !      write (iout,*)
7473 !     &  "Numbers of contacts to be received from other processors",
7474 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7475 !      call flush(iout)
7476 ! Receive contacts
7477       ireq=0
7478       do ii=1,ntask_cont_from
7479         iproc=itask_cont_from(ii)
7480         nn=ncont_recv(ii)
7481 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7482 !     &   " of CONT_TO_COMM group"
7483         call flush(iout)
7484         if (nn.gt.0) then
7485           ireq=ireq+1
7486           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7487           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7488 !          write (iout,*) "ireq,req",ireq,req(ireq)
7489         endif
7490       enddo
7491 ! Send the contacts to processors that need them
7492       do ii=1,ntask_cont_to
7493         iproc=itask_cont_to(ii)
7494         nn=ncont_sent(ii)
7495 !        write (iout,*) nn," contacts to processor",iproc,
7496 !     &   " of CONT_TO_COMM group"
7497         if (nn.gt.0) then
7498           ireq=ireq+1
7499           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7500             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7501 !          write (iout,*) "ireq,req",ireq,req(ireq)
7502 !          do i=1,nn
7503 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7504 !          enddo
7505         endif
7506       enddo
7507 !      write (iout,*) "number of requests (contacts)",ireq
7508 !      write (iout,*) "req",(req(i),i=1,4)
7509 !      call flush(iout)
7510       if (ireq.gt.0) &
7511        call MPI_Waitall(ireq,req,status_array,ierr)
7512       do iii=1,ntask_cont_from
7513         iproc=itask_cont_from(iii)
7514         nn=ncont_recv(iii)
7515         if (lprn) then
7516         write (iout,*) "Received",nn," contacts from processor",iproc,&
7517          " of CONT_FROM_COMM group"
7518         call flush(iout)
7519         do i=1,nn
7520           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7521         enddo
7522         call flush(iout)
7523         endif
7524         do i=1,nn
7525           ii=zapas_recv(1,i,iii)
7526 ! Flag the received contacts to prevent double-counting
7527           jj=-zapas_recv(2,i,iii)
7528 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7529 !          call flush(iout)
7530           nnn=num_cont_hb(ii)+1
7531           num_cont_hb(ii)=nnn
7532           jcont_hb(nnn,ii)=jj
7533           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7534           ind=3
7535           do kk=1,3
7536             ind=ind+1
7537             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7538           enddo
7539           do kk=1,2
7540             do ll=1,2
7541               ind=ind+1
7542               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7543             enddo
7544           enddo
7545           do jj=1,5
7546             do kk=1,3
7547               do ll=1,2
7548                 do mm=1,2
7549                   ind=ind+1
7550                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7551                 enddo
7552               enddo
7553             enddo
7554           enddo
7555         enddo
7556       enddo
7557       call flush(iout)
7558       if (lprn) then
7559         write (iout,'(a)') 'Contact function values after receive:'
7560         do i=nnt,nct-2
7561           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7562           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7563           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7564         enddo
7565         call flush(iout)
7566       endif
7567    30 continue
7568 #endif
7569       if (lprn) then
7570         write (iout,'(a)') 'Contact function values:'
7571         do i=nnt,nct-2
7572           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7573           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7574           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7575         enddo
7576       endif
7577       ecorr=0.0D0
7578       ecorr5=0.0d0
7579       ecorr6=0.0d0
7580
7581 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7582 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7583 ! Remove the loop below after debugging !!!
7584       do i=nnt,nct
7585         do j=1,3
7586           gradcorr(j,i)=0.0D0
7587           gradxorr(j,i)=0.0D0
7588         enddo
7589       enddo
7590 ! Calculate the dipole-dipole interaction energies
7591       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7592       do i=iatel_s,iatel_e+1
7593         num_conti=num_cont_hb(i)
7594         do jj=1,num_conti
7595           j=jcont_hb(jj,i)
7596 #ifdef MOMENT
7597           call dipole(i,j,jj)
7598 #endif
7599         enddo
7600       enddo
7601       endif
7602 ! Calculate the local-electrostatic correlation terms
7603 !                write (iout,*) "gradcorr5 in eello5 before loop"
7604 !                do iii=1,nres
7605 !                  write (iout,'(i5,3f10.5)')
7606 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7607 !                enddo
7608       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7609 !        write (iout,*) "corr loop i",i
7610         i1=i+1
7611         num_conti=num_cont_hb(i)
7612         num_conti1=num_cont_hb(i+1)
7613         do jj=1,num_conti
7614           j=jcont_hb(jj,i)
7615           jp=iabs(j)
7616           do kk=1,num_conti1
7617             j1=jcont_hb(kk,i1)
7618             jp1=iabs(j1)
7619 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7620 !     &         ' jj=',jj,' kk=',kk
7621 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7622             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7623                 .or. j.lt.0 .and. j1.gt.0) .and. &
7624                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7625 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7626 ! The system gains extra energy.
7627               n_corr=n_corr+1
7628               sqd1=dsqrt(d_cont(jj,i))
7629               sqd2=dsqrt(d_cont(kk,i1))
7630               sred_geom = sqd1*sqd2
7631               IF (sred_geom.lt.cutoff_corr) THEN
7632                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7633                   ekont,fprimcont)
7634 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7635 !d     &         ' jj=',jj,' kk=',kk
7636                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7637                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7638                 do l=1,3
7639                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7640                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7641                 enddo
7642                 n_corr1=n_corr1+1
7643 !d               write (iout,*) 'sred_geom=',sred_geom,
7644 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7645 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7646 !d               write (iout,*) "g_contij",g_contij
7647 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7648 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7649                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7650                 if (wcorr4.gt.0.0d0) &
7651                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7652                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7653                        write (iout,'(a6,4i5,0pf7.3)') &
7654                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7655 !                write (iout,*) "gradcorr5 before eello5"
7656 !                do iii=1,nres
7657 !                  write (iout,'(i5,3f10.5)')
7658 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7659 !                enddo
7660                 if (wcorr5.gt.0.0d0) &
7661                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7662 !                write (iout,*) "gradcorr5 after eello5"
7663 !                do iii=1,nres
7664 !                  write (iout,'(i5,3f10.5)')
7665 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7666 !                enddo
7667                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7668                        write (iout,'(a6,4i5,0pf7.3)') &
7669                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7670 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7671 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7672                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7673                      .or. wturn6.eq.0.0d0))then
7674 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7675                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7676                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7677                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7678 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7679 !d     &            'ecorr6=',ecorr6
7680 !d                write (iout,'(4e15.5)') sred_geom,
7681 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7682 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7683 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7684                 else if (wturn6.gt.0.0d0 &
7685                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7686 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7687                   eturn6=eturn6+eello_turn6(i,jj,kk)
7688                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7689                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7690 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7691                 endif
7692               ENDIF
7693 1111          continue
7694             endif
7695           enddo ! kk
7696         enddo ! jj
7697       enddo ! i
7698       do i=1,nres
7699         num_cont_hb(i)=num_cont_hb_old(i)
7700       enddo
7701 !                write (iout,*) "gradcorr5 in eello5"
7702 !                do iii=1,nres
7703 !                  write (iout,'(i5,3f10.5)')
7704 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7705 !                enddo
7706       return
7707       end subroutine multibody_eello
7708 !-----------------------------------------------------------------------------
7709       subroutine add_hb_contact_eello(ii,jj,itask)
7710 !      implicit real*8 (a-h,o-z)
7711 !      include "DIMENSIONS"
7712 !      include "COMMON.IOUNITS"
7713 !      include "COMMON.CONTACTS"
7714 !      integer,parameter :: maxconts=nres/4
7715       integer,parameter :: max_dim=70
7716       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7717 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7718 !      common /przechowalnia/ zapas
7719
7720       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7721       integer,dimension(4) ::itask
7722 !      write (iout,*) "itask",itask
7723       do i=1,2
7724         iproc=itask(i)
7725         if (iproc.gt.0) then
7726           do j=1,num_cont_hb(ii)
7727             jjc=jcont_hb(j,ii)
7728 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7729             if (jjc.eq.jj) then
7730               ncont_sent(iproc)=ncont_sent(iproc)+1
7731               nn=ncont_sent(iproc)
7732               zapas(1,nn,iproc)=ii
7733               zapas(2,nn,iproc)=jjc
7734               zapas(3,nn,iproc)=d_cont(j,ii)
7735               ind=3
7736               do kk=1,3
7737                 ind=ind+1
7738                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7739               enddo
7740               do kk=1,2
7741                 do ll=1,2
7742                   ind=ind+1
7743                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7744                 enddo
7745               enddo
7746               do jj=1,5
7747                 do kk=1,3
7748                   do ll=1,2
7749                     do mm=1,2
7750                       ind=ind+1
7751                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7752                     enddo
7753                   enddo
7754                 enddo
7755               enddo
7756               exit
7757             endif
7758           enddo
7759         endif
7760       enddo
7761       return
7762       end subroutine add_hb_contact_eello
7763 !-----------------------------------------------------------------------------
7764       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7765 !      implicit real*8 (a-h,o-z)
7766 !      include 'DIMENSIONS'
7767 !      include 'COMMON.IOUNITS'
7768 !      include 'COMMON.DERIV'
7769 !      include 'COMMON.INTERACT'
7770 !      include 'COMMON.CONTACTS'
7771       real(kind=8),dimension(3) :: gx,gx1
7772       logical :: lprn
7773 !el local variables
7774       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
7775       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
7776                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
7777                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
7778                    rlocshield
7779
7780       lprn=.false.
7781       eij=facont_hb(jj,i)
7782       ekl=facont_hb(kk,k)
7783       ees0pij=ees0p(jj,i)
7784       ees0pkl=ees0p(kk,k)
7785       ees0mij=ees0m(jj,i)
7786       ees0mkl=ees0m(kk,k)
7787       ekont=eij*ekl
7788       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7789 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7790 ! Following 4 lines for diagnostics.
7791 !d    ees0pkl=0.0D0
7792 !d    ees0pij=1.0D0
7793 !d    ees0mkl=0.0D0
7794 !d    ees0mij=1.0D0
7795 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7796 !     & 'Contacts ',i,j,
7797 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7798 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7799 !     & 'gradcorr_long'
7800 ! Calculate the multi-body contribution to energy.
7801 !      ecorr=ecorr+ekont*ees
7802 ! Calculate multi-body contributions to the gradient.
7803       coeffpees0pij=coeffp*ees0pij
7804       coeffmees0mij=coeffm*ees0mij
7805       coeffpees0pkl=coeffp*ees0pkl
7806       coeffmees0mkl=coeffm*ees0mkl
7807       do ll=1,3
7808 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7809         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
7810         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
7811         coeffmees0mkl*gacontm_hb1(ll,jj,i))
7812         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
7813         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
7814         coeffmees0mkl*gacontm_hb2(ll,jj,i))
7815 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7816         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
7817         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
7818         coeffmees0mij*gacontm_hb1(ll,kk,k))
7819         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
7820         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
7821         coeffmees0mij*gacontm_hb2(ll,kk,k))
7822         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
7823            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
7824            coeffmees0mkl*gacontm_hb3(ll,jj,i))
7825         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7826         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7827         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
7828            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
7829            coeffmees0mij*gacontm_hb3(ll,kk,k))
7830         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7831         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7832 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7833       enddo
7834 !      write (iout,*)
7835 !grad      do m=i+1,j-1
7836 !grad        do ll=1,3
7837 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7838 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7839 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7840 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7841 !grad        enddo
7842 !grad      enddo
7843 !grad      do m=k+1,l-1
7844 !grad        do ll=1,3
7845 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7846 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
7847 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7848 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7849 !grad        enddo
7850 !grad      enddo
7851 !      write (iout,*) "ehbcorr",ekont*ees
7852       ehbcorr=ekont*ees
7853       if (shield_mode.gt.0) then
7854        j=ees0plist(jj,i)
7855        l=ees0plist(kk,k)
7856 !C        print *,i,j,fac_shield(i),fac_shield(j),
7857 !C     &fac_shield(k),fac_shield(l)
7858         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
7859            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7860           do ilist=1,ishield_list(i)
7861            iresshield=shield_list(ilist,i)
7862            do m=1,3
7863            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7864            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7865                    rlocshield  &
7866             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7867             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7868             +rlocshield
7869            enddo
7870           enddo
7871           do ilist=1,ishield_list(j)
7872            iresshield=shield_list(ilist,j)
7873            do m=1,3
7874            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7875            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7876                    rlocshield &
7877             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7878            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7879             +rlocshield
7880            enddo
7881           enddo
7882
7883           do ilist=1,ishield_list(k)
7884            iresshield=shield_list(ilist,k)
7885            do m=1,3
7886            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7887            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7888                    rlocshield &
7889             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7890            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7891             +rlocshield
7892            enddo
7893           enddo
7894           do ilist=1,ishield_list(l)
7895            iresshield=shield_list(ilist,l)
7896            do m=1,3
7897            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7898            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7899                    rlocshield &
7900             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7901            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7902             +rlocshield
7903            enddo
7904           enddo
7905           do m=1,3
7906             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
7907                    grad_shield(m,i)*ehbcorr/fac_shield(i)
7908             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
7909                    grad_shield(m,j)*ehbcorr/fac_shield(j)
7910             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
7911                    grad_shield(m,i)*ehbcorr/fac_shield(i)
7912             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
7913                    grad_shield(m,j)*ehbcorr/fac_shield(j)
7914
7915             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
7916                    grad_shield(m,k)*ehbcorr/fac_shield(k)
7917             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
7918                    grad_shield(m,l)*ehbcorr/fac_shield(l)
7919             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
7920                    grad_shield(m,k)*ehbcorr/fac_shield(k)
7921             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
7922                    grad_shield(m,l)*ehbcorr/fac_shield(l)
7923
7924            enddo
7925       endif
7926       endif
7927       return
7928       end function ehbcorr
7929 #ifdef MOMENT
7930 !-----------------------------------------------------------------------------
7931       subroutine dipole(i,j,jj)
7932 !      implicit real*8 (a-h,o-z)
7933 !      include 'DIMENSIONS'
7934 !      include 'COMMON.IOUNITS'
7935 !      include 'COMMON.CHAIN'
7936 !      include 'COMMON.FFIELD'
7937 !      include 'COMMON.DERIV'
7938 !      include 'COMMON.INTERACT'
7939 !      include 'COMMON.CONTACTS'
7940 !      include 'COMMON.TORSION'
7941 !      include 'COMMON.VAR'
7942 !      include 'COMMON.GEO'
7943       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
7944       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
7945       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
7946
7947       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
7948       allocate(dipderx(3,5,4,maxconts,nres))
7949 !
7950
7951       iti1 = itortyp(itype(i+1,1))
7952       if (j.lt.nres-1) then
7953         itj1 = itortyp(itype(j+1,1))
7954       else
7955         itj1=ntortyp+1
7956       endif
7957       do iii=1,2
7958         dipi(iii,1)=Ub2(iii,i)
7959         dipderi(iii)=Ub2der(iii,i)
7960         dipi(iii,2)=b1(iii,iti1)
7961         dipj(iii,1)=Ub2(iii,j)
7962         dipderj(iii)=Ub2der(iii,j)
7963         dipj(iii,2)=b1(iii,itj1)
7964       enddo
7965       kkk=0
7966       do iii=1,2
7967         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7968         do jjj=1,2
7969           kkk=kkk+1
7970           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7971         enddo
7972       enddo
7973       do kkk=1,5
7974         do lll=1,3
7975           mmm=0
7976           do iii=1,2
7977             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
7978               auxvec(1))
7979             do jjj=1,2
7980               mmm=mmm+1
7981               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7982             enddo
7983           enddo
7984         enddo
7985       enddo
7986       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7987       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7988       do iii=1,2
7989         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7990       enddo
7991       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7992       do iii=1,2
7993         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7994       enddo
7995       return
7996       end subroutine dipole
7997 #endif
7998 !-----------------------------------------------------------------------------
7999       subroutine calc_eello(i,j,k,l,jj,kk)
8000 !
8001 ! This subroutine computes matrices and vectors needed to calculate
8002 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8003 !
8004       use comm_kut
8005 !      implicit real*8 (a-h,o-z)
8006 !      include 'DIMENSIONS'
8007 !      include 'COMMON.IOUNITS'
8008 !      include 'COMMON.CHAIN'
8009 !      include 'COMMON.DERIV'
8010 !      include 'COMMON.INTERACT'
8011 !      include 'COMMON.CONTACTS'
8012 !      include 'COMMON.TORSION'
8013 !      include 'COMMON.VAR'
8014 !      include 'COMMON.GEO'
8015 !      include 'COMMON.FFIELD'
8016       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8017       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8018       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8019               itj1
8020 !el      logical :: lprn
8021 !el      common /kutas/ lprn
8022 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8023 !d     & ' jj=',jj,' kk=',kk
8024 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8025 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8026 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8027       do iii=1,2
8028         do jjj=1,2
8029           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8030           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8031         enddo
8032       enddo
8033       call transpose2(aa1(1,1),aa1t(1,1))
8034       call transpose2(aa2(1,1),aa2t(1,1))
8035       do kkk=1,5
8036         do lll=1,3
8037           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8038             aa1tder(1,1,lll,kkk))
8039           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8040             aa2tder(1,1,lll,kkk))
8041         enddo
8042       enddo
8043       if (l.eq.j+1) then
8044 ! parallel orientation of the two CA-CA-CA frames.
8045         if (i.gt.1) then
8046           iti=itortyp(itype(i,1))
8047         else
8048           iti=ntortyp+1
8049         endif
8050         itk1=itortyp(itype(k+1,1))
8051         itj=itortyp(itype(j,1))
8052         if (l.lt.nres-1) then
8053           itl1=itortyp(itype(l+1,1))
8054         else
8055           itl1=ntortyp+1
8056         endif
8057 ! A1 kernel(j+1) A2T
8058 !d        do iii=1,2
8059 !d          write (iout,'(3f10.5,5x,3f10.5)')
8060 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8061 !d        enddo
8062         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8063          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8064          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8065 ! Following matrices are needed only for 6-th order cumulants
8066         IF (wcorr6.gt.0.0d0) THEN
8067         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8068          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8069          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8070         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8071          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8072          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8073          ADtEAderx(1,1,1,1,1,1))
8074         lprn=.false.
8075         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8076          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8077          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8078          ADtEA1derx(1,1,1,1,1,1))
8079         ENDIF
8080 ! End 6-th order cumulants
8081 !d        lprn=.false.
8082 !d        if (lprn) then
8083 !d        write (2,*) 'In calc_eello6'
8084 !d        do iii=1,2
8085 !d          write (2,*) 'iii=',iii
8086 !d          do kkk=1,5
8087 !d            write (2,*) 'kkk=',kkk
8088 !d            do jjj=1,2
8089 !d              write (2,'(3(2f10.5),5x)')
8090 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8091 !d            enddo
8092 !d          enddo
8093 !d        enddo
8094 !d        endif
8095         call transpose2(EUgder(1,1,k),auxmat(1,1))
8096         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8097         call transpose2(EUg(1,1,k),auxmat(1,1))
8098         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8099         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8100         do iii=1,2
8101           do kkk=1,5
8102             do lll=1,3
8103               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8104                 EAEAderx(1,1,lll,kkk,iii,1))
8105             enddo
8106           enddo
8107         enddo
8108 ! A1T kernel(i+1) A2
8109         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8110          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8111          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8112 ! Following matrices are needed only for 6-th order cumulants
8113         IF (wcorr6.gt.0.0d0) THEN
8114         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8115          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8116          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8117         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8118          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8119          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8120          ADtEAderx(1,1,1,1,1,2))
8121         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8122          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8123          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8124          ADtEA1derx(1,1,1,1,1,2))
8125         ENDIF
8126 ! End 6-th order cumulants
8127         call transpose2(EUgder(1,1,l),auxmat(1,1))
8128         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8129         call transpose2(EUg(1,1,l),auxmat(1,1))
8130         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8131         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8132         do iii=1,2
8133           do kkk=1,5
8134             do lll=1,3
8135               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8136                 EAEAderx(1,1,lll,kkk,iii,2))
8137             enddo
8138           enddo
8139         enddo
8140 ! AEAb1 and AEAb2
8141 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8142 ! They are needed only when the fifth- or the sixth-order cumulants are
8143 ! indluded.
8144         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8145         call transpose2(AEA(1,1,1),auxmat(1,1))
8146         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8147         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8148         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8149         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8150         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8151         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8152         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8153         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8154         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8155         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8156         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8157         call transpose2(AEA(1,1,2),auxmat(1,1))
8158         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8159         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8160         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8161         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8162         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8163         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8164         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8165         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8166         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8167         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8168         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8169 ! Calculate the Cartesian derivatives of the vectors.
8170         do iii=1,2
8171           do kkk=1,5
8172             do lll=1,3
8173               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8174               call matvec2(auxmat(1,1),b1(1,iti),&
8175                 AEAb1derx(1,lll,kkk,iii,1,1))
8176               call matvec2(auxmat(1,1),Ub2(1,i),&
8177                 AEAb2derx(1,lll,kkk,iii,1,1))
8178               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8179                 AEAb1derx(1,lll,kkk,iii,2,1))
8180               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8181                 AEAb2derx(1,lll,kkk,iii,2,1))
8182               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8183               call matvec2(auxmat(1,1),b1(1,itj),&
8184                 AEAb1derx(1,lll,kkk,iii,1,2))
8185               call matvec2(auxmat(1,1),Ub2(1,j),&
8186                 AEAb2derx(1,lll,kkk,iii,1,2))
8187               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8188                 AEAb1derx(1,lll,kkk,iii,2,2))
8189               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8190                 AEAb2derx(1,lll,kkk,iii,2,2))
8191             enddo
8192           enddo
8193         enddo
8194         ENDIF
8195 ! End vectors
8196       else
8197 ! Antiparallel orientation of the two CA-CA-CA frames.
8198         if (i.gt.1) then
8199           iti=itortyp(itype(i,1))
8200         else
8201           iti=ntortyp+1
8202         endif
8203         itk1=itortyp(itype(k+1,1))
8204         itl=itortyp(itype(l,1))
8205         itj=itortyp(itype(j,1))
8206         if (j.lt.nres-1) then
8207           itj1=itortyp(itype(j+1,1))
8208         else
8209           itj1=ntortyp+1
8210         endif
8211 ! A2 kernel(j-1)T A1T
8212         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8213          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8214          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8215 ! Following matrices are needed only for 6-th order cumulants
8216         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8217            j.eq.i+4 .and. l.eq.i+3)) THEN
8218         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8219          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8220          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8221         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8222          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8223          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8224          ADtEAderx(1,1,1,1,1,1))
8225         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8226          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8227          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8228          ADtEA1derx(1,1,1,1,1,1))
8229         ENDIF
8230 ! End 6-th order cumulants
8231         call transpose2(EUgder(1,1,k),auxmat(1,1))
8232         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8233         call transpose2(EUg(1,1,k),auxmat(1,1))
8234         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8235         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8236         do iii=1,2
8237           do kkk=1,5
8238             do lll=1,3
8239               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8240                 EAEAderx(1,1,lll,kkk,iii,1))
8241             enddo
8242           enddo
8243         enddo
8244 ! A2T kernel(i+1)T A1
8245         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8246          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8247          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8248 ! Following matrices are needed only for 6-th order cumulants
8249         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8250            j.eq.i+4 .and. l.eq.i+3)) THEN
8251         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8252          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8253          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8254         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8255          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8256          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8257          ADtEAderx(1,1,1,1,1,2))
8258         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8259          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8260          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8261          ADtEA1derx(1,1,1,1,1,2))
8262         ENDIF
8263 ! End 6-th order cumulants
8264         call transpose2(EUgder(1,1,j),auxmat(1,1))
8265         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8266         call transpose2(EUg(1,1,j),auxmat(1,1))
8267         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8268         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8269         do iii=1,2
8270           do kkk=1,5
8271             do lll=1,3
8272               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8273                 EAEAderx(1,1,lll,kkk,iii,2))
8274             enddo
8275           enddo
8276         enddo
8277 ! AEAb1 and AEAb2
8278 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8279 ! They are needed only when the fifth- or the sixth-order cumulants are
8280 ! indluded.
8281         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8282           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8283         call transpose2(AEA(1,1,1),auxmat(1,1))
8284         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8285         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8286         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8287         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8288         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8289         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8290         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8291         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8292         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8293         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8294         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8295         call transpose2(AEA(1,1,2),auxmat(1,1))
8296         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8297         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8298         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8299         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8300         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8301         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8302         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8303         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8304         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8305         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8306         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8307 ! Calculate the Cartesian derivatives of the vectors.
8308         do iii=1,2
8309           do kkk=1,5
8310             do lll=1,3
8311               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8312               call matvec2(auxmat(1,1),b1(1,iti),&
8313                 AEAb1derx(1,lll,kkk,iii,1,1))
8314               call matvec2(auxmat(1,1),Ub2(1,i),&
8315                 AEAb2derx(1,lll,kkk,iii,1,1))
8316               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8317                 AEAb1derx(1,lll,kkk,iii,2,1))
8318               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8319                 AEAb2derx(1,lll,kkk,iii,2,1))
8320               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8321               call matvec2(auxmat(1,1),b1(1,itl),&
8322                 AEAb1derx(1,lll,kkk,iii,1,2))
8323               call matvec2(auxmat(1,1),Ub2(1,l),&
8324                 AEAb2derx(1,lll,kkk,iii,1,2))
8325               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8326                 AEAb1derx(1,lll,kkk,iii,2,2))
8327               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8328                 AEAb2derx(1,lll,kkk,iii,2,2))
8329             enddo
8330           enddo
8331         enddo
8332         ENDIF
8333 ! End vectors
8334       endif
8335       return
8336       end subroutine calc_eello
8337 !-----------------------------------------------------------------------------
8338       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8339       use comm_kut
8340       implicit none
8341       integer :: nderg
8342       logical :: transp
8343       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8344       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8345       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8346       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8347       integer :: iii,kkk,lll
8348       integer :: jjj,mmm
8349 !el      logical :: lprn
8350 !el      common /kutas/ lprn
8351       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8352       do iii=1,nderg
8353         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8354           AKAderg(1,1,iii))
8355       enddo
8356 !d      if (lprn) write (2,*) 'In kernel'
8357       do kkk=1,5
8358 !d        if (lprn) write (2,*) 'kkk=',kkk
8359         do lll=1,3
8360           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8361             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8362 !d          if (lprn) then
8363 !d            write (2,*) 'lll=',lll
8364 !d            write (2,*) 'iii=1'
8365 !d            do jjj=1,2
8366 !d              write (2,'(3(2f10.5),5x)')
8367 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8368 !d            enddo
8369 !d          endif
8370           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8371             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8372 !d          if (lprn) then
8373 !d            write (2,*) 'lll=',lll
8374 !d            write (2,*) 'iii=2'
8375 !d            do jjj=1,2
8376 !d              write (2,'(3(2f10.5),5x)')
8377 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8378 !d            enddo
8379 !d          endif
8380         enddo
8381       enddo
8382       return
8383       end subroutine kernel
8384 !-----------------------------------------------------------------------------
8385       real(kind=8) function eello4(i,j,k,l,jj,kk)
8386 !      implicit real*8 (a-h,o-z)
8387 !      include 'DIMENSIONS'
8388 !      include 'COMMON.IOUNITS'
8389 !      include 'COMMON.CHAIN'
8390 !      include 'COMMON.DERIV'
8391 !      include 'COMMON.INTERACT'
8392 !      include 'COMMON.CONTACTS'
8393 !      include 'COMMON.TORSION'
8394 !      include 'COMMON.VAR'
8395 !      include 'COMMON.GEO'
8396       real(kind=8),dimension(2,2) :: pizda
8397       real(kind=8),dimension(3) :: ggg1,ggg2
8398       real(kind=8) ::  eel4,glongij,glongkl
8399       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8400 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8401 !d        eello4=0.0d0
8402 !d        return
8403 !d      endif
8404 !d      print *,'eello4:',i,j,k,l,jj,kk
8405 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8406 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8407 !old      eij=facont_hb(jj,i)
8408 !old      ekl=facont_hb(kk,k)
8409 !old      ekont=eij*ekl
8410       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8411 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8412       gcorr_loc(k-1)=gcorr_loc(k-1) &
8413          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8414       if (l.eq.j+1) then
8415         gcorr_loc(l-1)=gcorr_loc(l-1) &
8416            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8417       else
8418         gcorr_loc(j-1)=gcorr_loc(j-1) &
8419            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8420       endif
8421       do iii=1,2
8422         do kkk=1,5
8423           do lll=1,3
8424             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8425                               -EAEAderx(2,2,lll,kkk,iii,1)
8426 !d            derx(lll,kkk,iii)=0.0d0
8427           enddo
8428         enddo
8429       enddo
8430 !d      gcorr_loc(l-1)=0.0d0
8431 !d      gcorr_loc(j-1)=0.0d0
8432 !d      gcorr_loc(k-1)=0.0d0
8433 !d      eel4=1.0d0
8434 !d      write (iout,*)'Contacts have occurred for peptide groups',
8435 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8436 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8437       if (j.lt.nres-1) then
8438         j1=j+1
8439         j2=j-1
8440       else
8441         j1=j-1
8442         j2=j-2
8443       endif
8444       if (l.lt.nres-1) then
8445         l1=l+1
8446         l2=l-1
8447       else
8448         l1=l-1
8449         l2=l-2
8450       endif
8451       do ll=1,3
8452 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8453 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8454         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8455         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8456 !grad        ghalf=0.5d0*ggg1(ll)
8457         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8458         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8459         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8460         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8461         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8462         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8463 !grad        ghalf=0.5d0*ggg2(ll)
8464         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8465         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8466         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8467         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8468         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8469         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8470       enddo
8471 !grad      do m=i+1,j-1
8472 !grad        do ll=1,3
8473 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8474 !grad        enddo
8475 !grad      enddo
8476 !grad      do m=k+1,l-1
8477 !grad        do ll=1,3
8478 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8479 !grad        enddo
8480 !grad      enddo
8481 !grad      do m=i+2,j2
8482 !grad        do ll=1,3
8483 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8484 !grad        enddo
8485 !grad      enddo
8486 !grad      do m=k+2,l2
8487 !grad        do ll=1,3
8488 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8489 !grad        enddo
8490 !grad      enddo
8491 !d      do iii=1,nres-3
8492 !d        write (2,*) iii,gcorr_loc(iii)
8493 !d      enddo
8494       eello4=ekont*eel4
8495 !d      write (2,*) 'ekont',ekont
8496 !d      write (iout,*) 'eello4',ekont*eel4
8497       return
8498       end function eello4
8499 !-----------------------------------------------------------------------------
8500       real(kind=8) function eello5(i,j,k,l,jj,kk)
8501 !      implicit real*8 (a-h,o-z)
8502 !      include 'DIMENSIONS'
8503 !      include 'COMMON.IOUNITS'
8504 !      include 'COMMON.CHAIN'
8505 !      include 'COMMON.DERIV'
8506 !      include 'COMMON.INTERACT'
8507 !      include 'COMMON.CONTACTS'
8508 !      include 'COMMON.TORSION'
8509 !      include 'COMMON.VAR'
8510 !      include 'COMMON.GEO'
8511       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8512       real(kind=8),dimension(2) :: vv
8513       real(kind=8),dimension(3) :: ggg1,ggg2
8514       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8515       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8516       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8517 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8518 !                                                                              C
8519 !                            Parallel chains                                   C
8520 !                                                                              C
8521 !          o             o                   o             o                   C
8522 !         /l\           / \             \   / \           / \   /              C
8523 !        /   \         /   \             \ /   \         /   \ /               C
8524 !       j| o |l1       | o |              o| o |         | o |o                C
8525 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8526 !      \i/   \         /   \ /             /   \         /   \                 C
8527 !       o    k1             o                                                  C
8528 !         (I)          (II)                (III)          (IV)                 C
8529 !                                                                              C
8530 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8531 !                                                                              C
8532 !                            Antiparallel chains                               C
8533 !                                                                              C
8534 !          o             o                   o             o                   C
8535 !         /j\           / \             \   / \           / \   /              C
8536 !        /   \         /   \             \ /   \         /   \ /               C
8537 !      j1| o |l        | o |              o| o |         | o |o                C
8538 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8539 !      \i/   \         /   \ /             /   \         /   \                 C
8540 !       o     k1            o                                                  C
8541 !         (I)          (II)                (III)          (IV)                 C
8542 !                                                                              C
8543 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8544 !                                                                              C
8545 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8546 !                                                                              C
8547 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8548 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8549 !d        eello5=0.0d0
8550 !d        return
8551 !d      endif
8552 !d      write (iout,*)
8553 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8554 !d     &   ' and',k,l
8555       itk=itortyp(itype(k,1))
8556       itl=itortyp(itype(l,1))
8557       itj=itortyp(itype(j,1))
8558       eello5_1=0.0d0
8559       eello5_2=0.0d0
8560       eello5_3=0.0d0
8561       eello5_4=0.0d0
8562 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8563 !d     &   eel5_3_num,eel5_4_num)
8564       do iii=1,2
8565         do kkk=1,5
8566           do lll=1,3
8567             derx(lll,kkk,iii)=0.0d0
8568           enddo
8569         enddo
8570       enddo
8571 !d      eij=facont_hb(jj,i)
8572 !d      ekl=facont_hb(kk,k)
8573 !d      ekont=eij*ekl
8574 !d      write (iout,*)'Contacts have occurred for peptide groups',
8575 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8576 !d      goto 1111
8577 ! Contribution from the graph I.
8578 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8579 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8580       call transpose2(EUg(1,1,k),auxmat(1,1))
8581       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8582       vv(1)=pizda(1,1)-pizda(2,2)
8583       vv(2)=pizda(1,2)+pizda(2,1)
8584       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8585        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8586 ! Explicit gradient in virtual-dihedral angles.
8587       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8588        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8589        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8590       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8591       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8592       vv(1)=pizda(1,1)-pizda(2,2)
8593       vv(2)=pizda(1,2)+pizda(2,1)
8594       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8595        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8596        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8597       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8598       vv(1)=pizda(1,1)-pizda(2,2)
8599       vv(2)=pizda(1,2)+pizda(2,1)
8600       if (l.eq.j+1) then
8601         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8602          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8603          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8604       else
8605         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8606          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8607          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8608       endif
8609 ! Cartesian gradient
8610       do iii=1,2
8611         do kkk=1,5
8612           do lll=1,3
8613             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8614               pizda(1,1))
8615             vv(1)=pizda(1,1)-pizda(2,2)
8616             vv(2)=pizda(1,2)+pizda(2,1)
8617             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8618              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8619              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8620           enddo
8621         enddo
8622       enddo
8623 !      goto 1112
8624 !1111  continue
8625 ! Contribution from graph II
8626       call transpose2(EE(1,1,itk),auxmat(1,1))
8627       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8628       vv(1)=pizda(1,1)+pizda(2,2)
8629       vv(2)=pizda(2,1)-pizda(1,2)
8630       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8631        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8632 ! Explicit gradient in virtual-dihedral angles.
8633       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8634        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8635       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8636       vv(1)=pizda(1,1)+pizda(2,2)
8637       vv(2)=pizda(2,1)-pizda(1,2)
8638       if (l.eq.j+1) then
8639         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8640          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8641          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8642       else
8643         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8644          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8645          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8646       endif
8647 ! Cartesian gradient
8648       do iii=1,2
8649         do kkk=1,5
8650           do lll=1,3
8651             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8652               pizda(1,1))
8653             vv(1)=pizda(1,1)+pizda(2,2)
8654             vv(2)=pizda(2,1)-pizda(1,2)
8655             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8656              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8657              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8658           enddo
8659         enddo
8660       enddo
8661 !d      goto 1112
8662 !d1111  continue
8663       if (l.eq.j+1) then
8664 !d        goto 1110
8665 ! Parallel orientation
8666 ! Contribution from graph III
8667         call transpose2(EUg(1,1,l),auxmat(1,1))
8668         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8669         vv(1)=pizda(1,1)-pizda(2,2)
8670         vv(2)=pizda(1,2)+pizda(2,1)
8671         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8672          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8673 ! Explicit gradient in virtual-dihedral angles.
8674         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8675          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8676          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8677         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8678         vv(1)=pizda(1,1)-pizda(2,2)
8679         vv(2)=pizda(1,2)+pizda(2,1)
8680         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8681          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8682          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8683         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8684         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8685         vv(1)=pizda(1,1)-pizda(2,2)
8686         vv(2)=pizda(1,2)+pizda(2,1)
8687         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8688          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8689          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8690 ! Cartesian gradient
8691         do iii=1,2
8692           do kkk=1,5
8693             do lll=1,3
8694               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8695                 pizda(1,1))
8696               vv(1)=pizda(1,1)-pizda(2,2)
8697               vv(2)=pizda(1,2)+pizda(2,1)
8698               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8699                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8700                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8701             enddo
8702           enddo
8703         enddo
8704 !d        goto 1112
8705 ! Contribution from graph IV
8706 !d1110    continue
8707         call transpose2(EE(1,1,itl),auxmat(1,1))
8708         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8709         vv(1)=pizda(1,1)+pizda(2,2)
8710         vv(2)=pizda(2,1)-pizda(1,2)
8711         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8712          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8713 ! Explicit gradient in virtual-dihedral angles.
8714         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8715          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8716         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8717         vv(1)=pizda(1,1)+pizda(2,2)
8718         vv(2)=pizda(2,1)-pizda(1,2)
8719         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8720          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8721          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8722 ! Cartesian gradient
8723         do iii=1,2
8724           do kkk=1,5
8725             do lll=1,3
8726               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8727                 pizda(1,1))
8728               vv(1)=pizda(1,1)+pizda(2,2)
8729               vv(2)=pizda(2,1)-pizda(1,2)
8730               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8731                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8732                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8733             enddo
8734           enddo
8735         enddo
8736       else
8737 ! Antiparallel orientation
8738 ! Contribution from graph III
8739 !        goto 1110
8740         call transpose2(EUg(1,1,j),auxmat(1,1))
8741         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8742         vv(1)=pizda(1,1)-pizda(2,2)
8743         vv(2)=pizda(1,2)+pizda(2,1)
8744         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8745          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8746 ! Explicit gradient in virtual-dihedral angles.
8747         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8748          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8749          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8750         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8751         vv(1)=pizda(1,1)-pizda(2,2)
8752         vv(2)=pizda(1,2)+pizda(2,1)
8753         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8754          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
8755          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8756         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8757         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8758         vv(1)=pizda(1,1)-pizda(2,2)
8759         vv(2)=pizda(1,2)+pizda(2,1)
8760         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8761          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
8762          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8763 ! Cartesian gradient
8764         do iii=1,2
8765           do kkk=1,5
8766             do lll=1,3
8767               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8768                 pizda(1,1))
8769               vv(1)=pizda(1,1)-pizda(2,2)
8770               vv(2)=pizda(1,2)+pizda(2,1)
8771               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8772                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
8773                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8774             enddo
8775           enddo
8776         enddo
8777 !d        goto 1112
8778 ! Contribution from graph IV
8779 1110    continue
8780         call transpose2(EE(1,1,itj),auxmat(1,1))
8781         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8782         vv(1)=pizda(1,1)+pizda(2,2)
8783         vv(2)=pizda(2,1)-pizda(1,2)
8784         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
8785          -0.5d0*scalar2(vv(1),Ctobr(1,j))
8786 ! Explicit gradient in virtual-dihedral angles.
8787         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8788          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8789         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8790         vv(1)=pizda(1,1)+pizda(2,2)
8791         vv(2)=pizda(2,1)-pizda(1,2)
8792         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8793          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
8794          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8795 ! Cartesian gradient
8796         do iii=1,2
8797           do kkk=1,5
8798             do lll=1,3
8799               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8800                 pizda(1,1))
8801               vv(1)=pizda(1,1)+pizda(2,2)
8802               vv(2)=pizda(2,1)-pizda(1,2)
8803               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8804                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
8805                -0.5d0*scalar2(vv(1),Ctobr(1,j))
8806             enddo
8807           enddo
8808         enddo
8809       endif
8810 1112  continue
8811       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8812 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8813 !d        write (2,*) 'ijkl',i,j,k,l
8814 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8815 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8816 !d      endif
8817 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8818 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8819 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8820 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8821       if (j.lt.nres-1) then
8822         j1=j+1
8823         j2=j-1
8824       else
8825         j1=j-1
8826         j2=j-2
8827       endif
8828       if (l.lt.nres-1) then
8829         l1=l+1
8830         l2=l-1
8831       else
8832         l1=l-1
8833         l2=l-2
8834       endif
8835 !d      eij=1.0d0
8836 !d      ekl=1.0d0
8837 !d      ekont=1.0d0
8838 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8839 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
8840 !        summed up outside the subrouine as for the other subroutines
8841 !        handling long-range interactions. The old code is commented out
8842 !        with "cgrad" to keep track of changes.
8843       do ll=1,3
8844 !grad        ggg1(ll)=eel5*g_contij(ll,1)
8845 !grad        ggg2(ll)=eel5*g_contij(ll,2)
8846         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8847         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8848 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8849 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8850 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8851 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8852 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8853 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8854 !     &   gradcorr5ij,
8855 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8856 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8857 !grad        ghalf=0.5d0*ggg1(ll)
8858 !d        ghalf=0.0d0
8859         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8860         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8861         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8862         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8863         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8864         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8865 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8866 !grad        ghalf=0.5d0*ggg2(ll)
8867         ghalf=0.0d0
8868         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8869         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8870         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8871         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8872         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8873         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8874       enddo
8875 !d      goto 1112
8876 !grad      do m=i+1,j-1
8877 !grad        do ll=1,3
8878 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8879 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8880 !grad        enddo
8881 !grad      enddo
8882 !grad      do m=k+1,l-1
8883 !grad        do ll=1,3
8884 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8885 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8886 !grad        enddo
8887 !grad      enddo
8888 !1112  continue
8889 !grad      do m=i+2,j2
8890 !grad        do ll=1,3
8891 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8892 !grad        enddo
8893 !grad      enddo
8894 !grad      do m=k+2,l2
8895 !grad        do ll=1,3
8896 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8897 !grad        enddo
8898 !grad      enddo
8899 !d      do iii=1,nres-3
8900 !d        write (2,*) iii,g_corr5_loc(iii)
8901 !d      enddo
8902       eello5=ekont*eel5
8903 !d      write (2,*) 'ekont',ekont
8904 !d      write (iout,*) 'eello5',ekont*eel5
8905       return
8906       end function eello5
8907 !-----------------------------------------------------------------------------
8908       real(kind=8) function eello6(i,j,k,l,jj,kk)
8909 !      implicit real*8 (a-h,o-z)
8910 !      include 'DIMENSIONS'
8911 !      include 'COMMON.IOUNITS'
8912 !      include 'COMMON.CHAIN'
8913 !      include 'COMMON.DERIV'
8914 !      include 'COMMON.INTERACT'
8915 !      include 'COMMON.CONTACTS'
8916 !      include 'COMMON.TORSION'
8917 !      include 'COMMON.VAR'
8918 !      include 'COMMON.GEO'
8919 !      include 'COMMON.FFIELD'
8920       real(kind=8),dimension(3) :: ggg1,ggg2
8921       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
8922                    eello6_6,eel6
8923       real(kind=8) :: gradcorr6ij,gradcorr6kl
8924       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8925 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8926 !d        eello6=0.0d0
8927 !d        return
8928 !d      endif
8929 !d      write (iout,*)
8930 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8931 !d     &   ' and',k,l
8932       eello6_1=0.0d0
8933       eello6_2=0.0d0
8934       eello6_3=0.0d0
8935       eello6_4=0.0d0
8936       eello6_5=0.0d0
8937       eello6_6=0.0d0
8938 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8939 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8940       do iii=1,2
8941         do kkk=1,5
8942           do lll=1,3
8943             derx(lll,kkk,iii)=0.0d0
8944           enddo
8945         enddo
8946       enddo
8947 !d      eij=facont_hb(jj,i)
8948 !d      ekl=facont_hb(kk,k)
8949 !d      ekont=eij*ekl
8950 !d      eij=1.0d0
8951 !d      ekl=1.0d0
8952 !d      ekont=1.0d0
8953       if (l.eq.j+1) then
8954         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8955         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8956         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8957         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8958         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8959         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8960       else
8961         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8962         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8963         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8964         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8965         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8966           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8967         else
8968           eello6_5=0.0d0
8969         endif
8970         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8971       endif
8972 ! If turn contributions are considered, they will be handled separately.
8973       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8974 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8975 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8976 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8977 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8978 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8979 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8980 !d      goto 1112
8981       if (j.lt.nres-1) then
8982         j1=j+1
8983         j2=j-1
8984       else
8985         j1=j-1
8986         j2=j-2
8987       endif
8988       if (l.lt.nres-1) then
8989         l1=l+1
8990         l2=l-1
8991       else
8992         l1=l-1
8993         l2=l-2
8994       endif
8995       do ll=1,3
8996 !grad        ggg1(ll)=eel6*g_contij(ll,1)
8997 !grad        ggg2(ll)=eel6*g_contij(ll,2)
8998 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8999 !grad        ghalf=0.5d0*ggg1(ll)
9000 !d        ghalf=0.0d0
9001         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9002         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9003         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9004         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9005         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9006         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9007         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9008         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9009 !grad        ghalf=0.5d0*ggg2(ll)
9010 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9011 !d        ghalf=0.0d0
9012         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9013         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9014         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9015         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9016         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9017         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9018       enddo
9019 !d      goto 1112
9020 !grad      do m=i+1,j-1
9021 !grad        do ll=1,3
9022 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9023 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9024 !grad        enddo
9025 !grad      enddo
9026 !grad      do m=k+1,l-1
9027 !grad        do ll=1,3
9028 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9029 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9030 !grad        enddo
9031 !grad      enddo
9032 !grad1112  continue
9033 !grad      do m=i+2,j2
9034 !grad        do ll=1,3
9035 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9036 !grad        enddo
9037 !grad      enddo
9038 !grad      do m=k+2,l2
9039 !grad        do ll=1,3
9040 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9041 !grad        enddo
9042 !grad      enddo
9043 !d      do iii=1,nres-3
9044 !d        write (2,*) iii,g_corr6_loc(iii)
9045 !d      enddo
9046       eello6=ekont*eel6
9047 !d      write (2,*) 'ekont',ekont
9048 !d      write (iout,*) 'eello6',ekont*eel6
9049       return
9050       end function eello6
9051 !-----------------------------------------------------------------------------
9052       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9053       use comm_kut
9054 !      implicit real*8 (a-h,o-z)
9055 !      include 'DIMENSIONS'
9056 !      include 'COMMON.IOUNITS'
9057 !      include 'COMMON.CHAIN'
9058 !      include 'COMMON.DERIV'
9059 !      include 'COMMON.INTERACT'
9060 !      include 'COMMON.CONTACTS'
9061 !      include 'COMMON.TORSION'
9062 !      include 'COMMON.VAR'
9063 !      include 'COMMON.GEO'
9064       real(kind=8),dimension(2) :: vv,vv1
9065       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9066       logical :: swap
9067 !el      logical :: lprn
9068 !el      common /kutas/ lprn
9069       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9070       real(kind=8) :: s1,s2,s3,s4,s5
9071 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9072 !                                                                              C
9073 !      Parallel       Antiparallel                                             C
9074 !                                                                              C
9075 !          o             o                                                     C
9076 !         /l\           /j\                                                    C
9077 !        /   \         /   \                                                   C
9078 !       /| o |         | o |\                                                  C
9079 !     \ j|/k\|  /   \  |/k\|l /                                                C
9080 !      \ /   \ /     \ /   \ /                                                 C
9081 !       o     o       o     o                                                  C
9082 !       i             i                                                        C
9083 !                                                                              C
9084 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9085       itk=itortyp(itype(k,1))
9086       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9087       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9088       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9089       call transpose2(EUgC(1,1,k),auxmat(1,1))
9090       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9091       vv1(1)=pizda1(1,1)-pizda1(2,2)
9092       vv1(2)=pizda1(1,2)+pizda1(2,1)
9093       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9094       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9095       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9096       s5=scalar2(vv(1),Dtobr2(1,i))
9097 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9098       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9099       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9100        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9101        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9102        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9103        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9104        +scalar2(vv(1),Dtobr2der(1,i)))
9105       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9106       vv1(1)=pizda1(1,1)-pizda1(2,2)
9107       vv1(2)=pizda1(1,2)+pizda1(2,1)
9108       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9109       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9110       if (l.eq.j+1) then
9111         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9112        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9113        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9114        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9115        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9116       else
9117         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9118        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9119        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9120        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9121        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9122       endif
9123       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9124       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9125       vv1(1)=pizda1(1,1)-pizda1(2,2)
9126       vv1(2)=pizda1(1,2)+pizda1(2,1)
9127       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9128        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9129        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9130        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9131       do iii=1,2
9132         if (swap) then
9133           ind=3-iii
9134         else
9135           ind=iii
9136         endif
9137         do kkk=1,5
9138           do lll=1,3
9139             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9140             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9141             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9142             call transpose2(EUgC(1,1,k),auxmat(1,1))
9143             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9144               pizda1(1,1))
9145             vv1(1)=pizda1(1,1)-pizda1(2,2)
9146             vv1(2)=pizda1(1,2)+pizda1(2,1)
9147             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9148             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9149              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9150             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9151              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9152             s5=scalar2(vv(1),Dtobr2(1,i))
9153             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9154           enddo
9155         enddo
9156       enddo
9157       return
9158       end function eello6_graph1
9159 !-----------------------------------------------------------------------------
9160       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9161       use comm_kut
9162 !      implicit real*8 (a-h,o-z)
9163 !      include 'DIMENSIONS'
9164 !      include 'COMMON.IOUNITS'
9165 !      include 'COMMON.CHAIN'
9166 !      include 'COMMON.DERIV'
9167 !      include 'COMMON.INTERACT'
9168 !      include 'COMMON.CONTACTS'
9169 !      include 'COMMON.TORSION'
9170 !      include 'COMMON.VAR'
9171 !      include 'COMMON.GEO'
9172       logical :: swap
9173       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9174       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9175 !el      logical :: lprn
9176 !el      common /kutas/ lprn
9177       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9178       real(kind=8) :: s2,s3,s4
9179 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9180 !                                                                              C
9181 !      Parallel       Antiparallel                                             C
9182 !                                                                              C
9183 !          o             o                                                     C
9184 !     \   /l\           /j\   /                                                C
9185 !      \ /   \         /   \ /                                                 C
9186 !       o| o |         | o |o                                                  C
9187 !     \ j|/k\|      \  |/k\|l                                                  C
9188 !      \ /   \       \ /   \                                                   C
9189 !       o             o                                                        C
9190 !       i             i                                                        C
9191 !                                                                              C
9192 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9193 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9194 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9195 !           but not in a cluster cumulant
9196 #ifdef MOMENT
9197       s1=dip(1,jj,i)*dip(1,kk,k)
9198 #endif
9199       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9200       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9201       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9202       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9203       call transpose2(EUg(1,1,k),auxmat(1,1))
9204       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9205       vv(1)=pizda(1,1)-pizda(2,2)
9206       vv(2)=pizda(1,2)+pizda(2,1)
9207       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9208 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9209 #ifdef MOMENT
9210       eello6_graph2=-(s1+s2+s3+s4)
9211 #else
9212       eello6_graph2=-(s2+s3+s4)
9213 #endif
9214 !      eello6_graph2=-s3
9215 ! Derivatives in gamma(i-1)
9216       if (i.gt.1) then
9217 #ifdef MOMENT
9218         s1=dipderg(1,jj,i)*dip(1,kk,k)
9219 #endif
9220         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9221         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9222         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9223         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9224 #ifdef MOMENT
9225         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9226 #else
9227         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9228 #endif
9229 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9230       endif
9231 ! Derivatives in gamma(k-1)
9232 #ifdef MOMENT
9233       s1=dip(1,jj,i)*dipderg(1,kk,k)
9234 #endif
9235       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9236       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9237       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9238       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9239       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9240       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9241       vv(1)=pizda(1,1)-pizda(2,2)
9242       vv(2)=pizda(1,2)+pizda(2,1)
9243       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9244 #ifdef MOMENT
9245       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9246 #else
9247       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9248 #endif
9249 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9250 ! Derivatives in gamma(j-1) or gamma(l-1)
9251       if (j.gt.1) then
9252 #ifdef MOMENT
9253         s1=dipderg(3,jj,i)*dip(1,kk,k)
9254 #endif
9255         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9256         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9257         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9258         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9259         vv(1)=pizda(1,1)-pizda(2,2)
9260         vv(2)=pizda(1,2)+pizda(2,1)
9261         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9262 #ifdef MOMENT
9263         if (swap) then
9264           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9265         else
9266           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9267         endif
9268 #endif
9269         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9270 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9271       endif
9272 ! Derivatives in gamma(l-1) or gamma(j-1)
9273       if (l.gt.1) then
9274 #ifdef MOMENT
9275         s1=dip(1,jj,i)*dipderg(3,kk,k)
9276 #endif
9277         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9278         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9279         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9280         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9281         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9282         vv(1)=pizda(1,1)-pizda(2,2)
9283         vv(2)=pizda(1,2)+pizda(2,1)
9284         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9285 #ifdef MOMENT
9286         if (swap) then
9287           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9288         else
9289           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9290         endif
9291 #endif
9292         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9293 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9294       endif
9295 ! Cartesian derivatives.
9296       if (lprn) then
9297         write (2,*) 'In eello6_graph2'
9298         do iii=1,2
9299           write (2,*) 'iii=',iii
9300           do kkk=1,5
9301             write (2,*) 'kkk=',kkk
9302             do jjj=1,2
9303               write (2,'(3(2f10.5),5x)') &
9304               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9305             enddo
9306           enddo
9307         enddo
9308       endif
9309       do iii=1,2
9310         do kkk=1,5
9311           do lll=1,3
9312 #ifdef MOMENT
9313             if (iii.eq.1) then
9314               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9315             else
9316               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9317             endif
9318 #endif
9319             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9320               auxvec(1))
9321             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9322             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9323               auxvec(1))
9324             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9325             call transpose2(EUg(1,1,k),auxmat(1,1))
9326             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9327               pizda(1,1))
9328             vv(1)=pizda(1,1)-pizda(2,2)
9329             vv(2)=pizda(1,2)+pizda(2,1)
9330             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9331 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9332 #ifdef MOMENT
9333             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9334 #else
9335             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9336 #endif
9337             if (swap) then
9338               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9339             else
9340               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9341             endif
9342           enddo
9343         enddo
9344       enddo
9345       return
9346       end function eello6_graph2
9347 !-----------------------------------------------------------------------------
9348       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9349 !      implicit real*8 (a-h,o-z)
9350 !      include 'DIMENSIONS'
9351 !      include 'COMMON.IOUNITS'
9352 !      include 'COMMON.CHAIN'
9353 !      include 'COMMON.DERIV'
9354 !      include 'COMMON.INTERACT'
9355 !      include 'COMMON.CONTACTS'
9356 !      include 'COMMON.TORSION'
9357 !      include 'COMMON.VAR'
9358 !      include 'COMMON.GEO'
9359       real(kind=8),dimension(2) :: vv,auxvec
9360       real(kind=8),dimension(2,2) :: pizda,auxmat
9361       logical :: swap
9362       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9363       real(kind=8) :: s1,s2,s3,s4
9364 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9365 !                                                                              C
9366 !      Parallel       Antiparallel                                             C
9367 !                                                                              C
9368 !          o             o                                                     C
9369 !         /l\   /   \   /j\                                                    C
9370 !        /   \ /     \ /   \                                                   C
9371 !       /| o |o       o| o |\                                                  C
9372 !       j|/k\|  /      |/k\|l /                                                C
9373 !        /   \ /       /   \ /                                                 C
9374 !       /     o       /     o                                                  C
9375 !       i             i                                                        C
9376 !                                                                              C
9377 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9378 !
9379 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9380 !           energy moment and not to the cluster cumulant.
9381       iti=itortyp(itype(i,1))
9382       if (j.lt.nres-1) then
9383         itj1=itortyp(itype(j+1,1))
9384       else
9385         itj1=ntortyp+1
9386       endif
9387       itk=itortyp(itype(k,1))
9388       itk1=itortyp(itype(k+1,1))
9389       if (l.lt.nres-1) then
9390         itl1=itortyp(itype(l+1,1))
9391       else
9392         itl1=ntortyp+1
9393       endif
9394 #ifdef MOMENT
9395       s1=dip(4,jj,i)*dip(4,kk,k)
9396 #endif
9397       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9398       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9399       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9400       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9401       call transpose2(EE(1,1,itk),auxmat(1,1))
9402       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9403       vv(1)=pizda(1,1)+pizda(2,2)
9404       vv(2)=pizda(2,1)-pizda(1,2)
9405       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9406 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9407 !d     & "sum",-(s2+s3+s4)
9408 #ifdef MOMENT
9409       eello6_graph3=-(s1+s2+s3+s4)
9410 #else
9411       eello6_graph3=-(s2+s3+s4)
9412 #endif
9413 !      eello6_graph3=-s4
9414 ! Derivatives in gamma(k-1)
9415       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9416       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9417       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9418       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9419 ! Derivatives in gamma(l-1)
9420       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9421       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9422       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9423       vv(1)=pizda(1,1)+pizda(2,2)
9424       vv(2)=pizda(2,1)-pizda(1,2)
9425       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9426       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9427 ! Cartesian derivatives.
9428       do iii=1,2
9429         do kkk=1,5
9430           do lll=1,3
9431 #ifdef MOMENT
9432             if (iii.eq.1) then
9433               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9434             else
9435               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9436             endif
9437 #endif
9438             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9439               auxvec(1))
9440             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9441             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9442               auxvec(1))
9443             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9444             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9445               pizda(1,1))
9446             vv(1)=pizda(1,1)+pizda(2,2)
9447             vv(2)=pizda(2,1)-pizda(1,2)
9448             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9449 #ifdef MOMENT
9450             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9451 #else
9452             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9453 #endif
9454             if (swap) then
9455               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9456             else
9457               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9458             endif
9459 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9460           enddo
9461         enddo
9462       enddo
9463       return
9464       end function eello6_graph3
9465 !-----------------------------------------------------------------------------
9466       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9467 !      implicit real*8 (a-h,o-z)
9468 !      include 'DIMENSIONS'
9469 !      include 'COMMON.IOUNITS'
9470 !      include 'COMMON.CHAIN'
9471 !      include 'COMMON.DERIV'
9472 !      include 'COMMON.INTERACT'
9473 !      include 'COMMON.CONTACTS'
9474 !      include 'COMMON.TORSION'
9475 !      include 'COMMON.VAR'
9476 !      include 'COMMON.GEO'
9477 !      include 'COMMON.FFIELD'
9478       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9479       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9480       logical :: swap
9481       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9482               iii,kkk,lll
9483       real(kind=8) :: s1,s2,s3,s4
9484 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9485 !                                                                              C
9486 !      Parallel       Antiparallel                                             C
9487 !                                                                              C
9488 !          o             o                                                     C
9489 !         /l\   /   \   /j\                                                    C
9490 !        /   \ /     \ /   \                                                   C
9491 !       /| o |o       o| o |\                                                  C
9492 !     \ j|/k\|      \  |/k\|l                                                  C
9493 !      \ /   \       \ /   \                                                   C
9494 !       o     \       o     \                                                  C
9495 !       i             i                                                        C
9496 !                                                                              C
9497 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9498 !
9499 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9500 !           energy moment and not to the cluster cumulant.
9501 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9502       iti=itortyp(itype(i,1))
9503       itj=itortyp(itype(j,1))
9504       if (j.lt.nres-1) then
9505         itj1=itortyp(itype(j+1,1))
9506       else
9507         itj1=ntortyp+1
9508       endif
9509       itk=itortyp(itype(k,1))
9510       if (k.lt.nres-1) then
9511         itk1=itortyp(itype(k+1,1))
9512       else
9513         itk1=ntortyp+1
9514       endif
9515       itl=itortyp(itype(l,1))
9516       if (l.lt.nres-1) then
9517         itl1=itortyp(itype(l+1,1))
9518       else
9519         itl1=ntortyp+1
9520       endif
9521 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9522 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9523 !d     & ' itl',itl,' itl1',itl1
9524 #ifdef MOMENT
9525       if (imat.eq.1) then
9526         s1=dip(3,jj,i)*dip(3,kk,k)
9527       else
9528         s1=dip(2,jj,j)*dip(2,kk,l)
9529       endif
9530 #endif
9531       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9532       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9533       if (j.eq.l+1) then
9534         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9535         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9536       else
9537         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9538         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9539       endif
9540       call transpose2(EUg(1,1,k),auxmat(1,1))
9541       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9542       vv(1)=pizda(1,1)-pizda(2,2)
9543       vv(2)=pizda(2,1)+pizda(1,2)
9544       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9545 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9546 #ifdef MOMENT
9547       eello6_graph4=-(s1+s2+s3+s4)
9548 #else
9549       eello6_graph4=-(s2+s3+s4)
9550 #endif
9551 ! Derivatives in gamma(i-1)
9552       if (i.gt.1) then
9553 #ifdef MOMENT
9554         if (imat.eq.1) then
9555           s1=dipderg(2,jj,i)*dip(3,kk,k)
9556         else
9557           s1=dipderg(4,jj,j)*dip(2,kk,l)
9558         endif
9559 #endif
9560         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9561         if (j.eq.l+1) then
9562           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9563           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9564         else
9565           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9566           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9567         endif
9568         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9569         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9570 !d          write (2,*) 'turn6 derivatives'
9571 #ifdef MOMENT
9572           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9573 #else
9574           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9575 #endif
9576         else
9577 #ifdef MOMENT
9578           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9579 #else
9580           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9581 #endif
9582         endif
9583       endif
9584 ! Derivatives in gamma(k-1)
9585 #ifdef MOMENT
9586       if (imat.eq.1) then
9587         s1=dip(3,jj,i)*dipderg(2,kk,k)
9588       else
9589         s1=dip(2,jj,j)*dipderg(4,kk,l)
9590       endif
9591 #endif
9592       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9593       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9594       if (j.eq.l+1) then
9595         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9596         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9597       else
9598         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9599         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9600       endif
9601       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9602       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9603       vv(1)=pizda(1,1)-pizda(2,2)
9604       vv(2)=pizda(2,1)+pizda(1,2)
9605       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9606       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9607 #ifdef MOMENT
9608         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9609 #else
9610         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9611 #endif
9612       else
9613 #ifdef MOMENT
9614         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9615 #else
9616         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9617 #endif
9618       endif
9619 ! Derivatives in gamma(j-1) or gamma(l-1)
9620       if (l.eq.j+1 .and. l.gt.1) then
9621         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9622         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9623         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9624         vv(1)=pizda(1,1)-pizda(2,2)
9625         vv(2)=pizda(2,1)+pizda(1,2)
9626         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9627         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9628       else if (j.gt.1) then
9629         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9630         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9631         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9632         vv(1)=pizda(1,1)-pizda(2,2)
9633         vv(2)=pizda(2,1)+pizda(1,2)
9634         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9635         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9636           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9637         else
9638           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9639         endif
9640       endif
9641 ! Cartesian derivatives.
9642       do iii=1,2
9643         do kkk=1,5
9644           do lll=1,3
9645 #ifdef MOMENT
9646             if (iii.eq.1) then
9647               if (imat.eq.1) then
9648                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9649               else
9650                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9651               endif
9652             else
9653               if (imat.eq.1) then
9654                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9655               else
9656                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9657               endif
9658             endif
9659 #endif
9660             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9661               auxvec(1))
9662             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9663             if (j.eq.l+1) then
9664               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9665                 b1(1,itj1),auxvec(1))
9666               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9667             else
9668               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9669                 b1(1,itl1),auxvec(1))
9670               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9671             endif
9672             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9673               pizda(1,1))
9674             vv(1)=pizda(1,1)-pizda(2,2)
9675             vv(2)=pizda(2,1)+pizda(1,2)
9676             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9677             if (swap) then
9678               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9679 #ifdef MOMENT
9680                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9681                    -(s1+s2+s4)
9682 #else
9683                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9684                    -(s2+s4)
9685 #endif
9686                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9687               else
9688 #ifdef MOMENT
9689                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9690 #else
9691                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9692 #endif
9693                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9694               endif
9695             else
9696 #ifdef MOMENT
9697               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9698 #else
9699               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9700 #endif
9701               if (l.eq.j+1) then
9702                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9703               else
9704                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9705               endif
9706             endif
9707           enddo
9708         enddo
9709       enddo
9710       return
9711       end function eello6_graph4
9712 !-----------------------------------------------------------------------------
9713       real(kind=8) function eello_turn6(i,jj,kk)
9714 !      implicit real*8 (a-h,o-z)
9715 !      include 'DIMENSIONS'
9716 !      include 'COMMON.IOUNITS'
9717 !      include 'COMMON.CHAIN'
9718 !      include 'COMMON.DERIV'
9719 !      include 'COMMON.INTERACT'
9720 !      include 'COMMON.CONTACTS'
9721 !      include 'COMMON.TORSION'
9722 !      include 'COMMON.VAR'
9723 !      include 'COMMON.GEO'
9724       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9725       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9726       real(kind=8),dimension(3) :: ggg1,ggg2
9727       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9728       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9729 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9730 !           the respective energy moment and not to the cluster cumulant.
9731 !el local variables
9732       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9733       integer :: j1,j2,l1,l2,ll
9734       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9735       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9736       s1=0.0d0
9737       s8=0.0d0
9738       s13=0.0d0
9739 !
9740       eello_turn6=0.0d0
9741       j=i+4
9742       k=i+1
9743       l=i+3
9744       iti=itortyp(itype(i,1))
9745       itk=itortyp(itype(k,1))
9746       itk1=itortyp(itype(k+1,1))
9747       itl=itortyp(itype(l,1))
9748       itj=itortyp(itype(j,1))
9749 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9750 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
9751 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9752 !d        eello6=0.0d0
9753 !d        return
9754 !d      endif
9755 !d      write (iout,*)
9756 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9757 !d     &   ' and',k,l
9758 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
9759       do iii=1,2
9760         do kkk=1,5
9761           do lll=1,3
9762             derx_turn(lll,kkk,iii)=0.0d0
9763           enddo
9764         enddo
9765       enddo
9766 !d      eij=1.0d0
9767 !d      ekl=1.0d0
9768 !d      ekont=1.0d0
9769       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9770 !d      eello6_5=0.0d0
9771 !d      write (2,*) 'eello6_5',eello6_5
9772 #ifdef MOMENT
9773       call transpose2(AEA(1,1,1),auxmat(1,1))
9774       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9775       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9776       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9777 #endif
9778       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9779       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9780       s2 = scalar2(b1(1,itk),vtemp1(1))
9781 #ifdef MOMENT
9782       call transpose2(AEA(1,1,2),atemp(1,1))
9783       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9784       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9785       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9786 #endif
9787       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9788       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9789       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9790 #ifdef MOMENT
9791       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9792       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9793       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9794       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9795       ss13 = scalar2(b1(1,itk),vtemp4(1))
9796       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9797 #endif
9798 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9799 !      s1=0.0d0
9800 !      s2=0.0d0
9801 !      s8=0.0d0
9802 !      s12=0.0d0
9803 !      s13=0.0d0
9804       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9805 ! Derivatives in gamma(i+2)
9806       s1d =0.0d0
9807       s8d =0.0d0
9808 #ifdef MOMENT
9809       call transpose2(AEA(1,1,1),auxmatd(1,1))
9810       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9811       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9812       call transpose2(AEAderg(1,1,2),atempd(1,1))
9813       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9814       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9815 #endif
9816       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9817       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9818       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9819 !      s1d=0.0d0
9820 !      s2d=0.0d0
9821 !      s8d=0.0d0
9822 !      s12d=0.0d0
9823 !      s13d=0.0d0
9824       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9825 ! Derivatives in gamma(i+3)
9826 #ifdef MOMENT
9827       call transpose2(AEA(1,1,1),auxmatd(1,1))
9828       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9829       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9830       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9831 #endif
9832       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9833       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9834       s2d = scalar2(b1(1,itk),vtemp1d(1))
9835 #ifdef MOMENT
9836       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9837       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9838 #endif
9839       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9840 #ifdef MOMENT
9841       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9842       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9843       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9844 #endif
9845 !      s1d=0.0d0
9846 !      s2d=0.0d0
9847 !      s8d=0.0d0
9848 !      s12d=0.0d0
9849 !      s13d=0.0d0
9850 #ifdef MOMENT
9851       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9852                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9853 #else
9854       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9855                     -0.5d0*ekont*(s2d+s12d)
9856 #endif
9857 ! Derivatives in gamma(i+4)
9858       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9859       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9860       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9861 #ifdef MOMENT
9862       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9863       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9864       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9865 #endif
9866 !      s1d=0.0d0
9867 !      s2d=0.0d0
9868 !      s8d=0.0d0
9869 !      s12d=0.0d0
9870 !      s13d=0.0d0
9871 #ifdef MOMENT
9872       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9873 #else
9874       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9875 #endif
9876 ! Derivatives in gamma(i+5)
9877 #ifdef MOMENT
9878       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9879       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9880       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9881 #endif
9882       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9883       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9884       s2d = scalar2(b1(1,itk),vtemp1d(1))
9885 #ifdef MOMENT
9886       call transpose2(AEA(1,1,2),atempd(1,1))
9887       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9888       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9889 #endif
9890       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9891       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9892 #ifdef MOMENT
9893       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9894       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9895       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9896 #endif
9897 !      s1d=0.0d0
9898 !      s2d=0.0d0
9899 !      s8d=0.0d0
9900 !      s12d=0.0d0
9901 !      s13d=0.0d0
9902 #ifdef MOMENT
9903       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9904                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9905 #else
9906       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9907                     -0.5d0*ekont*(s2d+s12d)
9908 #endif
9909 ! Cartesian derivatives
9910       do iii=1,2
9911         do kkk=1,5
9912           do lll=1,3
9913 #ifdef MOMENT
9914             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9915             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9916             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9917 #endif
9918             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9919             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
9920                 vtemp1d(1))
9921             s2d = scalar2(b1(1,itk),vtemp1d(1))
9922 #ifdef MOMENT
9923             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9924             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9925             s8d = -(atempd(1,1)+atempd(2,2))* &
9926                  scalar2(cc(1,1,itl),vtemp2(1))
9927 #endif
9928             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
9929                  auxmatd(1,1))
9930             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9931             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9932 !      s1d=0.0d0
9933 !      s2d=0.0d0
9934 !      s8d=0.0d0
9935 !      s12d=0.0d0
9936 !      s13d=0.0d0
9937 #ifdef MOMENT
9938             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9939               - 0.5d0*(s1d+s2d)
9940 #else
9941             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9942               - 0.5d0*s2d
9943 #endif
9944 #ifdef MOMENT
9945             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9946               - 0.5d0*(s8d+s12d)
9947 #else
9948             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9949               - 0.5d0*s12d
9950 #endif
9951           enddo
9952         enddo
9953       enddo
9954 #ifdef MOMENT
9955       do kkk=1,5
9956         do lll=1,3
9957           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
9958             achuj_tempd(1,1))
9959           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9960           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9961           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9962           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9963           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
9964             vtemp4d(1))
9965           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9966           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9967           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9968         enddo
9969       enddo
9970 #endif
9971 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9972 !d     &  16*eel_turn6_num
9973 !d      goto 1112
9974       if (j.lt.nres-1) then
9975         j1=j+1
9976         j2=j-1
9977       else
9978         j1=j-1
9979         j2=j-2
9980       endif
9981       if (l.lt.nres-1) then
9982         l1=l+1
9983         l2=l-1
9984       else
9985         l1=l-1
9986         l2=l-2
9987       endif
9988       do ll=1,3
9989 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9990 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9991 !grad        ghalf=0.5d0*ggg1(ll)
9992 !d        ghalf=0.0d0
9993         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9994         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9995         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
9996           +ekont*derx_turn(ll,2,1)
9997         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9998         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
9999           +ekont*derx_turn(ll,4,1)
10000         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10001         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10002         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10003 !grad        ghalf=0.5d0*ggg2(ll)
10004 !d        ghalf=0.0d0
10005         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10006           +ekont*derx_turn(ll,2,2)
10007         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10008         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10009           +ekont*derx_turn(ll,4,2)
10010         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10011         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10012         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10013       enddo
10014 !d      goto 1112
10015 !grad      do m=i+1,j-1
10016 !grad        do ll=1,3
10017 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10018 !grad        enddo
10019 !grad      enddo
10020 !grad      do m=k+1,l-1
10021 !grad        do ll=1,3
10022 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10023 !grad        enddo
10024 !grad      enddo
10025 !grad1112  continue
10026 !grad      do m=i+2,j2
10027 !grad        do ll=1,3
10028 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10029 !grad        enddo
10030 !grad      enddo
10031 !grad      do m=k+2,l2
10032 !grad        do ll=1,3
10033 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10034 !grad        enddo
10035 !grad      enddo
10036 !d      do iii=1,nres-3
10037 !d        write (2,*) iii,g_corr6_loc(iii)
10038 !d      enddo
10039       eello_turn6=ekont*eel_turn6
10040 !d      write (2,*) 'ekont',ekont
10041 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10042       return
10043       end function eello_turn6
10044 !-----------------------------------------------------------------------------
10045       subroutine MATVEC2(A1,V1,V2)
10046 !DIR$ INLINEALWAYS MATVEC2
10047 #ifndef OSF
10048 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10049 #endif
10050 !      implicit real*8 (a-h,o-z)
10051 !      include 'DIMENSIONS'
10052       real(kind=8),dimension(2) :: V1,V2
10053       real(kind=8),dimension(2,2) :: A1
10054       real(kind=8) :: vaux1,vaux2
10055 !      DO 1 I=1,2
10056 !        VI=0.0
10057 !        DO 3 K=1,2
10058 !    3     VI=VI+A1(I,K)*V1(K)
10059 !        Vaux(I)=VI
10060 !    1 CONTINUE
10061
10062       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10063       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10064
10065       v2(1)=vaux1
10066       v2(2)=vaux2
10067       end subroutine MATVEC2
10068 !-----------------------------------------------------------------------------
10069       subroutine MATMAT2(A1,A2,A3)
10070 #ifndef OSF
10071 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10072 #endif
10073 !      implicit real*8 (a-h,o-z)
10074 !      include 'DIMENSIONS'
10075       real(kind=8),dimension(2,2) :: A1,A2,A3
10076       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10077 !      DIMENSION AI3(2,2)
10078 !        DO  J=1,2
10079 !          A3IJ=0.0
10080 !          DO K=1,2
10081 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10082 !          enddo
10083 !          A3(I,J)=A3IJ
10084 !       enddo
10085 !      enddo
10086
10087       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10088       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10089       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10090       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10091
10092       A3(1,1)=AI3_11
10093       A3(2,1)=AI3_21
10094       A3(1,2)=AI3_12
10095       A3(2,2)=AI3_22
10096       end subroutine MATMAT2
10097 !-----------------------------------------------------------------------------
10098       real(kind=8) function scalar2(u,v)
10099 !DIR$ INLINEALWAYS scalar2
10100       implicit none
10101       real(kind=8),dimension(2) :: u,v
10102       real(kind=8) :: sc
10103       integer :: i
10104       scalar2=u(1)*v(1)+u(2)*v(2)
10105       return
10106       end function scalar2
10107 !-----------------------------------------------------------------------------
10108       subroutine transpose2(a,at)
10109 !DIR$ INLINEALWAYS transpose2
10110 #ifndef OSF
10111 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10112 #endif
10113       implicit none
10114       real(kind=8),dimension(2,2) :: a,at
10115       at(1,1)=a(1,1)
10116       at(1,2)=a(2,1)
10117       at(2,1)=a(1,2)
10118       at(2,2)=a(2,2)
10119       return
10120       end subroutine transpose2
10121 !-----------------------------------------------------------------------------
10122       subroutine transpose(n,a,at)
10123       implicit none
10124       integer :: n,i,j
10125       real(kind=8),dimension(n,n) :: a,at
10126       do i=1,n
10127         do j=1,n
10128           at(j,i)=a(i,j)
10129         enddo
10130       enddo
10131       return
10132       end subroutine transpose
10133 !-----------------------------------------------------------------------------
10134       subroutine prodmat3(a1,a2,kk,transp,prod)
10135 !DIR$ INLINEALWAYS prodmat3
10136 #ifndef OSF
10137 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10138 #endif
10139       implicit none
10140       integer :: i,j
10141       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10142       logical :: transp
10143 !rc      double precision auxmat(2,2),prod_(2,2)
10144
10145       if (transp) then
10146 !rc        call transpose2(kk(1,1),auxmat(1,1))
10147 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10148 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10149
10150            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10151        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10152            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10153        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10154            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10155        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10156            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10157        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10158
10159       else
10160 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10161 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10162
10163            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10164         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10165            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10166         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10167            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10168         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10169            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10170         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10171
10172       endif
10173 !      call transpose2(a2(1,1),a2t(1,1))
10174
10175 !rc      print *,transp
10176 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10177 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10178
10179       return
10180       end subroutine prodmat3
10181 !-----------------------------------------------------------------------------
10182 ! energy_p_new_barrier.F
10183 !-----------------------------------------------------------------------------
10184       subroutine sum_gradient
10185 !      implicit real*8 (a-h,o-z)
10186       use io_base, only: pdbout
10187 !      include 'DIMENSIONS'
10188 #ifndef ISNAN
10189       external proc_proc
10190 #ifdef WINPGI
10191 !MS$ATTRIBUTES C ::  proc_proc
10192 #endif
10193 #endif
10194 #ifdef MPI
10195       include 'mpif.h'
10196 #endif
10197       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10198                    gloc_scbuf !(3,maxres)
10199
10200       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10201 !#endif
10202 !el local variables
10203       integer :: i,j,k,ierror,ierr
10204       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10205                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10206                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10207                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10208                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10209                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10210                    gsccorr_max,gsccorrx_max,time00
10211
10212 !      include 'COMMON.SETUP'
10213 !      include 'COMMON.IOUNITS'
10214 !      include 'COMMON.FFIELD'
10215 !      include 'COMMON.DERIV'
10216 !      include 'COMMON.INTERACT'
10217 !      include 'COMMON.SBRIDGE'
10218 !      include 'COMMON.CHAIN'
10219 !      include 'COMMON.VAR'
10220 !      include 'COMMON.CONTROL'
10221 !      include 'COMMON.TIME1'
10222 !      include 'COMMON.MAXGRAD'
10223 !      include 'COMMON.SCCOR'
10224 #ifdef TIMING
10225       time01=MPI_Wtime()
10226 #endif
10227 #ifdef DEBUG
10228       write (iout,*) "sum_gradient gvdwc, gvdwx"
10229       do i=1,nres
10230         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10231          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10232       enddo
10233       call flush(iout)
10234 #endif
10235 #ifdef MPI
10236         gradbufc=0.0d0
10237         gradbufx=0.0d0
10238         gradbufc_sum=0.0d0
10239         gloc_scbuf=0.0d0
10240         glocbuf=0.0d0
10241 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10242         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10243           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10244 #endif
10245 !
10246 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10247 !            in virtual-bond-vector coordinates
10248 !
10249 #ifdef DEBUG
10250 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10251 !      do i=1,nres-1
10252 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10253 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10254 !      enddo
10255 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10256 !      do i=1,nres-1
10257 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10258 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10259 !      enddo
10260       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10261       do i=1,nres
10262         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10263          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10264          (gvdwc_scpp(j,i),j=1,3)
10265       enddo
10266       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10267       do i=1,nres
10268         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10269          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10270          (gelc_loc_long(j,i),j=1,3)
10271       enddo
10272       call flush(iout)
10273 #endif
10274 #ifdef SPLITELE
10275       do i=0,nct
10276         do j=1,3
10277           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10278                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10279                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10280                       wel_loc*gel_loc_long(j,i)+ &
10281                       wcorr*gradcorr_long(j,i)+ &
10282                       wcorr5*gradcorr5_long(j,i)+ &
10283                       wcorr6*gradcorr6_long(j,i)+ &
10284                       wturn6*gcorr6_turn_long(j,i)+ &
10285                       wstrain*ghpbc(j,i) &
10286                      +wliptran*gliptranc(j,i) &
10287                      +gradafm(j,i) &
10288                      +welec*gshieldc(j,i) &
10289                      +wcorr*gshieldc_ec(j,i) &
10290                      +wturn3*gshieldc_t3(j,i)&
10291                      +wturn4*gshieldc_t4(j,i)&
10292                      +wel_loc*gshieldc_ll(j,i)&
10293                      +wtube*gg_tube(j,i)
10294
10295
10296
10297         enddo
10298       enddo
10299 #else
10300       do i=0,nct
10301         do j=1,3
10302           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10303                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10304                       welec*gelc_long(j,i)+ &
10305                       wbond*gradb(j,i)+ &
10306                       wel_loc*gel_loc_long(j,i)+ &
10307                       wcorr*gradcorr_long(j,i)+ &
10308                       wcorr5*gradcorr5_long(j,i)+ &
10309                       wcorr6*gradcorr6_long(j,i)+ &
10310                       wturn6*gcorr6_turn_long(j,i)+ &
10311                       wstrain*ghpbc(j,i) &
10312                      +wliptran*gliptranc(j,i) &
10313                      +gradafm(j,i) &
10314                      +welec*gshieldc(j,i)&
10315                      +wcorr*gshieldc_ec(j,i) &
10316                      +wturn4*gshieldc_t4(j,i) &
10317                      +wel_loc*gshieldc_ll(j,i)&
10318                      +wtube*gg_tube(j,i)
10319
10320
10321
10322         enddo
10323       enddo
10324 #endif
10325 #ifdef MPI
10326       if (nfgtasks.gt.1) then
10327       time00=MPI_Wtime()
10328 #ifdef DEBUG
10329       write (iout,*) "gradbufc before allreduce"
10330       do i=1,nres
10331         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10332       enddo
10333       call flush(iout)
10334 #endif
10335       do i=0,nres
10336         do j=1,3
10337           gradbufc_sum(j,i)=gradbufc(j,i)
10338         enddo
10339       enddo
10340 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10341 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10342 !      time_reduce=time_reduce+MPI_Wtime()-time00
10343 #ifdef DEBUG
10344 !      write (iout,*) "gradbufc_sum after allreduce"
10345 !      do i=1,nres
10346 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10347 !      enddo
10348 !      call flush(iout)
10349 #endif
10350 #ifdef TIMING
10351 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10352 #endif
10353       do i=0,nres
10354         do k=1,3
10355           gradbufc(k,i)=0.0d0
10356         enddo
10357       enddo
10358 #ifdef DEBUG
10359       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10360       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10361                         " jgrad_end  ",jgrad_end(i),&
10362                         i=igrad_start,igrad_end)
10363 #endif
10364 !
10365 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10366 ! do not parallelize this part.
10367 !
10368 !      do i=igrad_start,igrad_end
10369 !        do j=jgrad_start(i),jgrad_end(i)
10370 !          do k=1,3
10371 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10372 !          enddo
10373 !        enddo
10374 !      enddo
10375       do j=1,3
10376         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10377       enddo
10378       do i=nres-2,-1,-1
10379         do j=1,3
10380           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10381         enddo
10382       enddo
10383 #ifdef DEBUG
10384       write (iout,*) "gradbufc after summing"
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       else
10391 #endif
10392 !el#define DEBUG
10393 #ifdef DEBUG
10394       write (iout,*) "gradbufc"
10395       do i=1,nres
10396         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10397       enddo
10398       call flush(iout)
10399 #endif
10400 !el#undef DEBUG
10401       do i=-1,nres
10402         do j=1,3
10403           gradbufc_sum(j,i)=gradbufc(j,i)
10404           gradbufc(j,i)=0.0d0
10405         enddo
10406       enddo
10407       do j=1,3
10408         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10409       enddo
10410       do i=nres-2,-1,-1
10411         do j=1,3
10412           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10413         enddo
10414       enddo
10415 !      do i=nnt,nres-1
10416 !        do k=1,3
10417 !          gradbufc(k,i)=0.0d0
10418 !        enddo
10419 !        do j=i+1,nres
10420 !          do k=1,3
10421 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10422 !          enddo
10423 !        enddo
10424 !      enddo
10425 !el#define DEBUG
10426 #ifdef DEBUG
10427       write (iout,*) "gradbufc after summing"
10428       do i=1,nres
10429         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10430       enddo
10431       call flush(iout)
10432 #endif
10433 !el#undef DEBUG
10434 #ifdef MPI
10435       endif
10436 #endif
10437       do k=1,3
10438         gradbufc(k,nres)=0.0d0
10439       enddo
10440 !el----------------
10441 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10442 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10443 !el-----------------
10444       do i=-1,nct
10445         do j=1,3
10446 #ifdef SPLITELE
10447           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10448                       wel_loc*gel_loc(j,i)+ &
10449                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10450                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10451                       wel_loc*gel_loc_long(j,i)+ &
10452                       wcorr*gradcorr_long(j,i)+ &
10453                       wcorr5*gradcorr5_long(j,i)+ &
10454                       wcorr6*gradcorr6_long(j,i)+ &
10455                       wturn6*gcorr6_turn_long(j,i))+ &
10456                       wbond*gradb(j,i)+ &
10457                       wcorr*gradcorr(j,i)+ &
10458                       wturn3*gcorr3_turn(j,i)+ &
10459                       wturn4*gcorr4_turn(j,i)+ &
10460                       wcorr5*gradcorr5(j,i)+ &
10461                       wcorr6*gradcorr6(j,i)+ &
10462                       wturn6*gcorr6_turn(j,i)+ &
10463                       wsccor*gsccorc(j,i) &
10464                      +wscloc*gscloc(j,i)  &
10465                      +wliptran*gliptranc(j,i) &
10466                      +gradafm(j,i) &
10467                      +welec*gshieldc(j,i) &
10468                      +welec*gshieldc_loc(j,i) &
10469                      +wcorr*gshieldc_ec(j,i) &
10470                      +wcorr*gshieldc_loc_ec(j,i) &
10471                      +wturn3*gshieldc_t3(j,i) &
10472                      +wturn3*gshieldc_loc_t3(j,i) &
10473                      +wturn4*gshieldc_t4(j,i) &
10474                      +wturn4*gshieldc_loc_t4(j,i) &
10475                      +wel_loc*gshieldc_ll(j,i) &
10476                      +wel_loc*gshieldc_loc_ll(j,i) &
10477                      +wtube*gg_tube(j,i)
10478
10479
10480 #else
10481           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10482                       wel_loc*gel_loc(j,i)+ &
10483                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10484                       welec*gelc_long(j,i)+ &
10485                       wel_loc*gel_loc_long(j,i)+ &
10486 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10487                       wcorr5*gradcorr5_long(j,i)+ &
10488                       wcorr6*gradcorr6_long(j,i)+ &
10489                       wturn6*gcorr6_turn_long(j,i))+ &
10490                       wbond*gradb(j,i)+ &
10491                       wcorr*gradcorr(j,i)+ &
10492                       wturn3*gcorr3_turn(j,i)+ &
10493                       wturn4*gcorr4_turn(j,i)+ &
10494                       wcorr5*gradcorr5(j,i)+ &
10495                       wcorr6*gradcorr6(j,i)+ &
10496                       wturn6*gcorr6_turn(j,i)+ &
10497                       wsccor*gsccorc(j,i) &
10498                      +wscloc*gscloc(j,i) &
10499                      +gradafm(j,i) &
10500                      +wliptran*gliptranc(j,i) &
10501                      +welec*gshieldc(j,i) &
10502                      +welec*gshieldc_loc(j,) &
10503                      +wcorr*gshieldc_ec(j,i) &
10504                      +wcorr*gshieldc_loc_ec(j,i) &
10505                      +wturn3*gshieldc_t3(j,i) &
10506                      +wturn3*gshieldc_loc_t3(j,i) &
10507                      +wturn4*gshieldc_t4(j,i) &
10508                      +wturn4*gshieldc_loc_t4(j,i) &
10509                      +wel_loc*gshieldc_ll(j,i) &
10510                      +wel_loc*gshieldc_loc_ll(j,i) &
10511                      +wtube*gg_tube(j,i)
10512
10513
10514
10515 #endif
10516           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10517                         wbond*gradbx(j,i)+ &
10518                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10519                         wsccor*gsccorx(j,i) &
10520                        +wscloc*gsclocx(j,i) &
10521                        +wliptran*gliptranx(j,i) &
10522                        +welec*gshieldx(j,i)     &
10523                        +wcorr*gshieldx_ec(j,i)  &
10524                        +wturn3*gshieldx_t3(j,i) &
10525                        +wturn4*gshieldx_t4(j,i) &
10526                        +wel_loc*gshieldx_ll(j,i)&
10527                        +wtube*gg_tube_sc(j,i)
10528
10529
10530         enddo
10531       enddo
10532 #ifdef DEBUG
10533       write (iout,*) "gloc before adding corr"
10534       do i=1,4*nres
10535         write (iout,*) i,gloc(i,icg)
10536       enddo
10537 #endif
10538       do i=1,nres-3
10539         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10540          +wcorr5*g_corr5_loc(i) &
10541          +wcorr6*g_corr6_loc(i) &
10542          +wturn4*gel_loc_turn4(i) &
10543          +wturn3*gel_loc_turn3(i) &
10544          +wturn6*gel_loc_turn6(i) &
10545          +wel_loc*gel_loc_loc(i)
10546       enddo
10547 #ifdef DEBUG
10548       write (iout,*) "gloc after adding corr"
10549       do i=1,4*nres
10550         write (iout,*) i,gloc(i,icg)
10551       enddo
10552 #endif
10553 #ifdef MPI
10554       if (nfgtasks.gt.1) then
10555         do j=1,3
10556           do i=1,nres
10557             gradbufc(j,i)=gradc(j,i,icg)
10558             gradbufx(j,i)=gradx(j,i,icg)
10559           enddo
10560         enddo
10561         do i=1,4*nres
10562           glocbuf(i)=gloc(i,icg)
10563         enddo
10564 !#define DEBUG
10565 #ifdef DEBUG
10566       write (iout,*) "gloc_sc before reduce"
10567       do i=1,nres
10568        do j=1,1
10569         write (iout,*) i,j,gloc_sc(j,i,icg)
10570        enddo
10571       enddo
10572 #endif
10573 !#undef DEBUG
10574         do i=1,nres
10575          do j=1,3
10576           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10577          enddo
10578         enddo
10579         time00=MPI_Wtime()
10580         call MPI_Barrier(FG_COMM,IERR)
10581         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10582         time00=MPI_Wtime()
10583         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10584           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10585         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
10586           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10587         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10588           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10589         time_reduce=time_reduce+MPI_Wtime()-time00
10590         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10591           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10592         time_reduce=time_reduce+MPI_Wtime()-time00
10593 !#define DEBUG
10594 #ifdef DEBUG
10595       write (iout,*) "gloc_sc after reduce"
10596       do i=1,nres
10597        do j=1,1
10598         write (iout,*) i,j,gloc_sc(j,i,icg)
10599        enddo
10600       enddo
10601 #endif
10602 !#undef DEBUG
10603 #ifdef DEBUG
10604       write (iout,*) "gloc after reduce"
10605       do i=1,4*nres
10606         write (iout,*) i,gloc(i,icg)
10607       enddo
10608 #endif
10609       endif
10610 #endif
10611       if (gnorm_check) then
10612 !
10613 ! Compute the maximum elements of the gradient
10614 !
10615       gvdwc_max=0.0d0
10616       gvdwc_scp_max=0.0d0
10617       gelc_max=0.0d0
10618       gvdwpp_max=0.0d0
10619       gradb_max=0.0d0
10620       ghpbc_max=0.0d0
10621       gradcorr_max=0.0d0
10622       gel_loc_max=0.0d0
10623       gcorr3_turn_max=0.0d0
10624       gcorr4_turn_max=0.0d0
10625       gradcorr5_max=0.0d0
10626       gradcorr6_max=0.0d0
10627       gcorr6_turn_max=0.0d0
10628       gsccorc_max=0.0d0
10629       gscloc_max=0.0d0
10630       gvdwx_max=0.0d0
10631       gradx_scp_max=0.0d0
10632       ghpbx_max=0.0d0
10633       gradxorr_max=0.0d0
10634       gsccorx_max=0.0d0
10635       gsclocx_max=0.0d0
10636       do i=1,nct
10637         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10638         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10639         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10640         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10641          gvdwc_scp_max=gvdwc_scp_norm
10642         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10643         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10644         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10645         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10646         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10647         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10648         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10649         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10650         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10651         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10652         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10653         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10654         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10655           gcorr3_turn(1,i)))
10656         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10657           gcorr3_turn_max=gcorr3_turn_norm
10658         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10659           gcorr4_turn(1,i)))
10660         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10661           gcorr4_turn_max=gcorr4_turn_norm
10662         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10663         if (gradcorr5_norm.gt.gradcorr5_max) &
10664           gradcorr5_max=gradcorr5_norm
10665         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10666         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10667         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10668           gcorr6_turn(1,i)))
10669         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10670           gcorr6_turn_max=gcorr6_turn_norm
10671         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
10672         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
10673         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
10674         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
10675         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
10676         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
10677         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
10678         if (gradx_scp_norm.gt.gradx_scp_max) &
10679           gradx_scp_max=gradx_scp_norm
10680         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
10681         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
10682         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
10683         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
10684         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
10685         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
10686         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
10687         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
10688       enddo
10689       if (gradout) then
10690 #ifdef AIX
10691         open(istat,file=statname,position="append")
10692 #else
10693         open(istat,file=statname,access="append")
10694 #endif
10695         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
10696            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
10697            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
10698            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
10699            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
10700            gsccorx_max,gsclocx_max
10701         close(istat)
10702         if (gvdwc_max.gt.1.0d4) then
10703           write (iout,*) "gvdwc gvdwx gradb gradbx"
10704           do i=nnt,nct
10705             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
10706               gradb(j,i),gradbx(j,i),j=1,3)
10707           enddo
10708           call pdbout(0.0d0,'cipiszcze',iout)
10709           call flush(iout)
10710         endif
10711       endif
10712       endif
10713 !el#define DEBUG
10714 #ifdef DEBUG
10715       write (iout,*) "gradc gradx gloc"
10716       do i=1,nres
10717         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
10718          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
10719       enddo
10720 #endif
10721 !el#undef DEBUG
10722 #ifdef TIMING
10723       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
10724 #endif
10725       return
10726       end subroutine sum_gradient
10727 !-----------------------------------------------------------------------------
10728       subroutine sc_grad
10729 !      implicit real*8 (a-h,o-z)
10730       use calc_data
10731 !      include 'DIMENSIONS'
10732 !      include 'COMMON.CHAIN'
10733 !      include 'COMMON.DERIV'
10734 !      include 'COMMON.CALC'
10735 !      include 'COMMON.IOUNITS'
10736       real(kind=8), dimension(3) :: dcosom1,dcosom2
10737
10738       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
10739       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
10740       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
10741            -2.0D0*alf12*eps3der+sigder*sigsq_om12
10742 ! diagnostics only
10743 !      eom1=0.0d0
10744 !      eom2=0.0d0
10745 !      eom12=evdwij*eps1_om12
10746 ! end diagnostics
10747 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
10748 !       " sigder",sigder
10749 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
10750 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
10751 !C      print *,sss_ele_cut,'in sc_grad'
10752       do k=1,3
10753         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
10754         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
10755       enddo
10756       do k=1,3
10757         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
10758 !C      print *,'gg',k,gg(k)
10759        enddo
10760 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
10761 !      write (iout,*) "gg",(gg(k),k=1,3)
10762       do k=1,3
10763         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
10764                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10765                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
10766                   *sss_ele_cut
10767
10768         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
10769                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10770                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
10771                   *sss_ele_cut
10772
10773 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10774 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
10775 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10776 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
10777       enddo
10778 !
10779 ! Calculate the components of the gradient in DC and X
10780 !
10781 !grad      do k=i,j-1
10782 !grad        do l=1,3
10783 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
10784 !grad        enddo
10785 !grad      enddo
10786       do l=1,3
10787         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
10788         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
10789       enddo
10790       return
10791       end subroutine sc_grad
10792 #ifdef CRYST_THETA
10793 !-----------------------------------------------------------------------------
10794       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
10795
10796       use comm_calcthet
10797 !      implicit real*8 (a-h,o-z)
10798 !      include 'DIMENSIONS'
10799 !      include 'COMMON.LOCAL'
10800 !      include 'COMMON.IOUNITS'
10801 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
10802 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10803 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
10804       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
10805       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
10806 !el      integer :: it
10807 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
10808 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10809 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
10810 !el local variables
10811
10812       delthec=thetai-thet_pred_mean
10813       delthe0=thetai-theta0i
10814 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
10815       t3 = thetai-thet_pred_mean
10816       t6 = t3**2
10817       t9 = term1
10818       t12 = t3*sigcsq
10819       t14 = t12+t6*sigsqtc
10820       t16 = 1.0d0
10821       t21 = thetai-theta0i
10822       t23 = t21**2
10823       t26 = term2
10824       t27 = t21*t26
10825       t32 = termexp
10826       t40 = t32**2
10827       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
10828        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
10829        *(-t12*t9-ak*sig0inv*t27)
10830       return
10831       end subroutine mixder
10832 #endif
10833 !-----------------------------------------------------------------------------
10834 ! cartder.F
10835 !-----------------------------------------------------------------------------
10836       subroutine cartder
10837 !-----------------------------------------------------------------------------
10838 ! This subroutine calculates the derivatives of the consecutive virtual
10839 ! bond vectors and the SC vectors in the virtual-bond angles theta and
10840 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
10841 ! in the angles alpha and omega, describing the location of a side chain
10842 ! in its local coordinate system.
10843 !
10844 ! The derivatives are stored in the following arrays:
10845 !
10846 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
10847 ! The structure is as follows:
10848 !
10849 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
10850 ! 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)
10851 !         . . . . . . . . . . . .  . . . . . .
10852 ! 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)
10853 !                          .
10854 !                          .
10855 !                          .
10856 ! 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)
10857 !
10858 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
10859 ! The structure is same as above.
10860 !
10861 ! DCDS - the derivatives of the side chain vectors in the local spherical
10862 ! andgles alph and omega:
10863 !
10864 ! 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)
10865 ! 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)
10866 !                          .
10867 !                          .
10868 !                          .
10869 ! 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)
10870 !
10871 ! Version of March '95, based on an early version of November '91.
10872 !
10873 !**********************************************************************
10874 !      implicit real*8 (a-h,o-z)
10875 !      include 'DIMENSIONS'
10876 !      include 'COMMON.VAR'
10877 !      include 'COMMON.CHAIN'
10878 !      include 'COMMON.DERIV'
10879 !      include 'COMMON.GEO'
10880 !      include 'COMMON.LOCAL'
10881 !      include 'COMMON.INTERACT'
10882       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
10883       real(kind=8),dimension(3,3) :: dp,temp
10884 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
10885       real(kind=8),dimension(3) :: xx,xx1
10886 !el local variables
10887       integer :: i,k,l,j,m,ind,ind1,jjj
10888       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
10889                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
10890                  sint2,xp,yp,xxp,yyp,zzp,dj
10891
10892 !      common /przechowalnia/ fromto
10893       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
10894 ! get the position of the jth ijth fragment of the chain coordinate system
10895 ! in the fromto array.
10896 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
10897 !
10898 !      maxdim=(nres-1)*(nres-2)/2
10899 !      allocate(dcdv(6,maxdim),dxds(6,nres))
10900 ! calculate the derivatives of transformation matrix elements in theta
10901 !
10902
10903 !el      call flush(iout) !el
10904       do i=1,nres-2
10905         rdt(1,1,i)=-rt(1,2,i)
10906         rdt(1,2,i)= rt(1,1,i)
10907         rdt(1,3,i)= 0.0d0
10908         rdt(2,1,i)=-rt(2,2,i)
10909         rdt(2,2,i)= rt(2,1,i)
10910         rdt(2,3,i)= 0.0d0
10911         rdt(3,1,i)=-rt(3,2,i)
10912         rdt(3,2,i)= rt(3,1,i)
10913         rdt(3,3,i)= 0.0d0
10914       enddo
10915 !
10916 ! derivatives in phi
10917 !
10918       do i=2,nres-2
10919         drt(1,1,i)= 0.0d0
10920         drt(1,2,i)= 0.0d0
10921         drt(1,3,i)= 0.0d0
10922         drt(2,1,i)= rt(3,1,i)
10923         drt(2,2,i)= rt(3,2,i)
10924         drt(2,3,i)= rt(3,3,i)
10925         drt(3,1,i)=-rt(2,1,i)
10926         drt(3,2,i)=-rt(2,2,i)
10927         drt(3,3,i)=-rt(2,3,i)
10928       enddo
10929 !
10930 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
10931 !
10932       do i=2,nres-2
10933         ind=indmat(i,i+1)
10934         do k=1,3
10935           do l=1,3
10936             temp(k,l)=rt(k,l,i)
10937           enddo
10938         enddo
10939         do k=1,3
10940           do l=1,3
10941             fromto(k,l,ind)=temp(k,l)
10942           enddo
10943         enddo
10944         do j=i+1,nres-2
10945           ind=indmat(i,j+1)
10946           do k=1,3
10947             do l=1,3
10948               dpkl=0.0d0
10949               do m=1,3
10950                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
10951               enddo
10952               dp(k,l)=dpkl
10953               fromto(k,l,ind)=dpkl
10954             enddo
10955           enddo
10956           do k=1,3
10957             do l=1,3
10958               temp(k,l)=dp(k,l)
10959             enddo
10960           enddo
10961         enddo
10962       enddo
10963 !
10964 ! Calculate derivatives.
10965 !
10966       ind1=0
10967       do i=1,nres-2
10968         ind1=ind1+1
10969 !
10970 ! Derivatives of DC(i+1) in theta(i+2)
10971 !
10972         do j=1,3
10973           do k=1,2
10974             dpjk=0.0D0
10975             do l=1,3
10976               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
10977             enddo
10978             dp(j,k)=dpjk
10979             prordt(j,k,i)=dp(j,k)
10980           enddo
10981           dp(j,3)=0.0D0
10982           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
10983         enddo
10984 !
10985 ! Derivatives of SC(i+1) in theta(i+2)
10986 !
10987         xx1(1)=-0.5D0*xloc(2,i+1)
10988         xx1(2)= 0.5D0*xloc(1,i+1)
10989         do j=1,3
10990           xj=0.0D0
10991           do k=1,2
10992             xj=xj+r(j,k,i)*xx1(k)
10993           enddo
10994           xx(j)=xj
10995         enddo
10996         do j=1,3
10997           rj=0.0D0
10998           do k=1,3
10999             rj=rj+prod(j,k,i)*xx(k)
11000           enddo
11001           dxdv(j,ind1)=rj
11002         enddo
11003 !
11004 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11005 ! than the other off-diagonal derivatives.
11006 !
11007         do j=1,3
11008           dxoiij=0.0D0
11009           do k=1,3
11010             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11011           enddo
11012           dxdv(j,ind1+1)=dxoiij
11013         enddo
11014 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11015 !
11016 ! Derivatives of DC(i+1) in phi(i+2)
11017 !
11018         do j=1,3
11019           do k=1,3
11020             dpjk=0.0
11021             do l=2,3
11022               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11023             enddo
11024             dp(j,k)=dpjk
11025             prodrt(j,k,i)=dp(j,k)
11026           enddo
11027           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11028         enddo
11029 !
11030 ! Derivatives of SC(i+1) in phi(i+2)
11031 !
11032         xx(1)= 0.0D0
11033         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11034         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11035         do j=1,3
11036           rj=0.0D0
11037           do k=2,3
11038             rj=rj+prod(j,k,i)*xx(k)
11039           enddo
11040           dxdv(j+3,ind1)=-rj
11041         enddo
11042 !
11043 ! Derivatives of SC(i+1) in phi(i+3).
11044 !
11045         do j=1,3
11046           dxoiij=0.0D0
11047           do k=1,3
11048             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11049           enddo
11050           dxdv(j+3,ind1+1)=dxoiij
11051         enddo
11052 !
11053 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11054 ! theta(nres) and phi(i+3) thru phi(nres).
11055 !
11056         do j=i+1,nres-2
11057           ind1=ind1+1
11058           ind=indmat(i+1,j+1)
11059 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11060           do k=1,3
11061             do l=1,3
11062               tempkl=0.0D0
11063               do m=1,2
11064                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11065               enddo
11066               temp(k,l)=tempkl
11067             enddo
11068           enddo
11069 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11070 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11071 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11072 ! Derivatives of virtual-bond vectors in theta
11073           do k=1,3
11074             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11075           enddo
11076 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11077 ! Derivatives of SC vectors in theta
11078           do k=1,3
11079             dxoijk=0.0D0
11080             do l=1,3
11081               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11082             enddo
11083             dxdv(k,ind1+1)=dxoijk
11084           enddo
11085 !
11086 !--- Calculate the derivatives in phi
11087 !
11088           do k=1,3
11089             do l=1,3
11090               tempkl=0.0D0
11091               do m=1,3
11092                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11093               enddo
11094               temp(k,l)=tempkl
11095             enddo
11096           enddo
11097           do k=1,3
11098             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11099           enddo
11100           do k=1,3
11101             dxoijk=0.0D0
11102             do l=1,3
11103               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11104             enddo
11105             dxdv(k+3,ind1+1)=dxoijk
11106           enddo
11107         enddo
11108       enddo
11109 !
11110 ! Derivatives in alpha and omega:
11111 !
11112       do i=2,nres-1
11113 !       dsci=dsc(itype(i,1))
11114         dsci=vbld(i+nres)
11115 #ifdef OSF
11116         alphi=alph(i)
11117         omegi=omeg(i)
11118         if(alphi.ne.alphi) alphi=100.0
11119         if(omegi.ne.omegi) omegi=-100.0
11120 #else
11121         alphi=alph(i)
11122         omegi=omeg(i)
11123 #endif
11124 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11125         cosalphi=dcos(alphi)
11126         sinalphi=dsin(alphi)
11127         cosomegi=dcos(omegi)
11128         sinomegi=dsin(omegi)
11129         temp(1,1)=-dsci*sinalphi
11130         temp(2,1)= dsci*cosalphi*cosomegi
11131         temp(3,1)=-dsci*cosalphi*sinomegi
11132         temp(1,2)=0.0D0
11133         temp(2,2)=-dsci*sinalphi*sinomegi
11134         temp(3,2)=-dsci*sinalphi*cosomegi
11135         theta2=pi-0.5D0*theta(i+1)
11136         cost2=dcos(theta2)
11137         sint2=dsin(theta2)
11138         jjj=0
11139 !d      print *,((temp(l,k),l=1,3),k=1,2)
11140         do j=1,2
11141           xp=temp(1,j)
11142           yp=temp(2,j)
11143           xxp= xp*cost2+yp*sint2
11144           yyp=-xp*sint2+yp*cost2
11145           zzp=temp(3,j)
11146           xx(1)=xxp
11147           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11148           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11149           do k=1,3
11150             dj=0.0D0
11151             do l=1,3
11152               dj=dj+prod(k,l,i-1)*xx(l)
11153             enddo
11154             dxds(jjj+k,i)=dj
11155           enddo
11156           jjj=jjj+3
11157         enddo
11158       enddo
11159       return
11160       end subroutine cartder
11161 !-----------------------------------------------------------------------------
11162 ! checkder_p.F
11163 !-----------------------------------------------------------------------------
11164       subroutine check_cartgrad
11165 ! Check the gradient of Cartesian coordinates in internal coordinates.
11166 !      implicit real*8 (a-h,o-z)
11167 !      include 'DIMENSIONS'
11168 !      include 'COMMON.IOUNITS'
11169 !      include 'COMMON.VAR'
11170 !      include 'COMMON.CHAIN'
11171 !      include 'COMMON.GEO'
11172 !      include 'COMMON.LOCAL'
11173 !      include 'COMMON.DERIV'
11174       real(kind=8),dimension(6,nres) :: temp
11175       real(kind=8),dimension(3) :: xx,gg
11176       integer :: i,k,j,ii
11177       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11178 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11179 !
11180 ! Check the gradient of the virtual-bond and SC vectors in the internal
11181 ! coordinates.
11182 !
11183       aincr=1.0d-6
11184       aincr2=5.0d-7
11185       call cartder
11186       write (iout,'(a)') '**************** dx/dalpha'
11187       write (iout,'(a)')
11188       do i=2,nres-1
11189         alphi=alph(i)
11190         alph(i)=alph(i)+aincr
11191         do k=1,3
11192           temp(k,i)=dc(k,nres+i)
11193         enddo
11194         call chainbuild
11195         do k=1,3
11196           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11197           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11198         enddo
11199         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11200         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11201         write (iout,'(a)')
11202         alph(i)=alphi
11203         call chainbuild
11204       enddo
11205       write (iout,'(a)')
11206       write (iout,'(a)') '**************** dx/domega'
11207       write (iout,'(a)')
11208       do i=2,nres-1
11209         omegi=omeg(i)
11210         omeg(i)=omeg(i)+aincr
11211         do k=1,3
11212           temp(k,i)=dc(k,nres+i)
11213         enddo
11214         call chainbuild
11215         do k=1,3
11216           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11217           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11218                 (aincr*dabs(dxds(k+3,i))+aincr))
11219         enddo
11220         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11221             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11222         write (iout,'(a)')
11223         omeg(i)=omegi
11224         call chainbuild
11225       enddo
11226       write (iout,'(a)')
11227       write (iout,'(a)') '**************** dx/dtheta'
11228       write (iout,'(a)')
11229       do i=3,nres
11230         theti=theta(i)
11231         theta(i)=theta(i)+aincr
11232         do j=i-1,nres-1
11233           do k=1,3
11234             temp(k,j)=dc(k,nres+j)
11235           enddo
11236         enddo
11237         call chainbuild
11238         do j=i-1,nres-1
11239           ii = indmat(i-2,j)
11240 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11241           do k=1,3
11242             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11243             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11244                   (aincr*dabs(dxdv(k,ii))+aincr))
11245           enddo
11246           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11247               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11248           write(iout,'(a)')
11249         enddo
11250         write (iout,'(a)')
11251         theta(i)=theti
11252         call chainbuild
11253       enddo
11254       write (iout,'(a)') '***************** dx/dphi'
11255       write (iout,'(a)')
11256       do i=4,nres
11257         phi(i)=phi(i)+aincr
11258         do j=i-1,nres-1
11259           do k=1,3
11260             temp(k,j)=dc(k,nres+j)
11261           enddo
11262         enddo
11263         call chainbuild
11264         do j=i-1,nres-1
11265           ii = indmat(i-2,j)
11266 !         print *,'ii=',ii
11267           do k=1,3
11268             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11269             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11270                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11271           enddo
11272           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11273               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11274           write(iout,'(a)')
11275         enddo
11276         phi(i)=phi(i)-aincr
11277         call chainbuild
11278       enddo
11279       write (iout,'(a)') '****************** ddc/dtheta'
11280       do i=1,nres-2
11281         thet=theta(i+2)
11282         theta(i+2)=thet+aincr
11283         do j=i,nres
11284           do k=1,3
11285             temp(k,j)=dc(k,j)
11286           enddo
11287         enddo
11288         call chainbuild
11289         do j=i+1,nres-1
11290           ii = indmat(i,j)
11291 !         print *,'ii=',ii
11292           do k=1,3
11293             gg(k)=(dc(k,j)-temp(k,j))/aincr
11294             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11295                  (aincr*dabs(dcdv(k,ii))+aincr))
11296           enddo
11297           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11298                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11299           write (iout,'(a)')
11300         enddo
11301         do j=1,nres
11302           do k=1,3
11303             dc(k,j)=temp(k,j)
11304           enddo
11305         enddo
11306         theta(i+2)=thet
11307       enddo
11308       write (iout,'(a)') '******************* ddc/dphi'
11309       do i=1,nres-3
11310         phii=phi(i+3)
11311         phi(i+3)=phii+aincr
11312         do j=1,nres
11313           do k=1,3
11314             temp(k,j)=dc(k,j)
11315           enddo
11316         enddo
11317         call chainbuild
11318         do j=i+2,nres-1
11319           ii = indmat(i+1,j)
11320 !         print *,'ii=',ii
11321           do k=1,3
11322             gg(k)=(dc(k,j)-temp(k,j))/aincr
11323             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11324                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11325           enddo
11326           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11327                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11328           write (iout,'(a)')
11329         enddo
11330         do j=1,nres
11331           do k=1,3
11332             dc(k,j)=temp(k,j)
11333           enddo
11334         enddo
11335         phi(i+3)=phii
11336       enddo
11337       return
11338       end subroutine check_cartgrad
11339 !-----------------------------------------------------------------------------
11340       subroutine check_ecart
11341 ! Check the gradient of the energy in Cartesian coordinates.
11342 !     implicit real*8 (a-h,o-z)
11343 !     include 'DIMENSIONS'
11344 !     include 'COMMON.CHAIN'
11345 !     include 'COMMON.DERIV'
11346 !     include 'COMMON.IOUNITS'
11347 !     include 'COMMON.VAR'
11348 !     include 'COMMON.CONTACTS'
11349       use comm_srutu
11350 !el      integer :: icall
11351 !el      common /srutu/ icall
11352       real(kind=8),dimension(6) :: ggg
11353       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11354       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11355       real(kind=8),dimension(6,nres) :: grad_s
11356       real(kind=8),dimension(0:n_ene) :: energia,energia1
11357       integer :: uiparm(1)
11358       real(kind=8) :: urparm(1)
11359 !EL      external fdum
11360       integer :: nf,i,j,k
11361       real(kind=8) :: aincr,etot,etot1
11362       icg=1
11363       nf=0
11364       nfl=0
11365       call zerograd
11366       aincr=1.0D-5
11367       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11368       nf=0
11369       icall=0
11370       call geom_to_var(nvar,x)
11371       call etotal(energia)
11372       etot=energia(0)
11373 !el      call enerprint(energia)
11374       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11375       icall =1
11376       do i=1,nres
11377         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11378       enddo
11379       do i=1,nres
11380         do j=1,3
11381           grad_s(j,i)=gradc(j,i,icg)
11382           grad_s(j+3,i)=gradx(j,i,icg)
11383         enddo
11384       enddo
11385       call flush(iout)
11386       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11387       do i=1,nres
11388         do j=1,3
11389           xx(j)=c(j,i+nres)
11390           ddc(j)=dc(j,i)
11391           ddx(j)=dc(j,i+nres)
11392         enddo
11393         do j=1,3
11394           dc(j,i)=dc(j,i)+aincr
11395           do k=i+1,nres
11396             c(j,k)=c(j,k)+aincr
11397             c(j,k+nres)=c(j,k+nres)+aincr
11398           enddo
11399           call etotal(energia1)
11400           etot1=energia1(0)
11401           ggg(j)=(etot1-etot)/aincr
11402           dc(j,i)=ddc(j)
11403           do k=i+1,nres
11404             c(j,k)=c(j,k)-aincr
11405             c(j,k+nres)=c(j,k+nres)-aincr
11406           enddo
11407         enddo
11408         do j=1,3
11409           c(j,i+nres)=c(j,i+nres)+aincr
11410           dc(j,i+nres)=dc(j,i+nres)+aincr
11411           call etotal(energia1)
11412           etot1=energia1(0)
11413           ggg(j+3)=(etot1-etot)/aincr
11414           c(j,i+nres)=xx(j)
11415           dc(j,i+nres)=ddx(j)
11416         enddo
11417         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11418          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11419       enddo
11420       return
11421       end subroutine check_ecart
11422 #ifdef CARGRAD
11423 !-----------------------------------------------------------------------------
11424       subroutine check_ecartint
11425 ! Check the gradient of the energy in Cartesian coordinates.
11426       use io_base, only: intout
11427 !      implicit real*8 (a-h,o-z)
11428 !      include 'DIMENSIONS'
11429 !      include 'COMMON.CONTROL'
11430 !      include 'COMMON.CHAIN'
11431 !      include 'COMMON.DERIV'
11432 !      include 'COMMON.IOUNITS'
11433 !      include 'COMMON.VAR'
11434 !      include 'COMMON.CONTACTS'
11435 !      include 'COMMON.MD'
11436 !      include 'COMMON.LOCAL'
11437 !      include 'COMMON.SPLITELE'
11438       use comm_srutu
11439 !el      integer :: icall
11440 !el      common /srutu/ icall
11441       real(kind=8),dimension(6) :: ggg,ggg1
11442       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11443       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11444       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11445       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11446       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11447       real(kind=8),dimension(0:n_ene) :: energia,energia1
11448       integer :: uiparm(1)
11449       real(kind=8) :: urparm(1)
11450 !EL      external fdum
11451       integer :: i,j,k,nf
11452       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11453                    etot21,etot22
11454       r_cut=2.0d0
11455       rlambd=0.3d0
11456       icg=1
11457       nf=0
11458       nfl=0
11459       call intout
11460 !      call intcartderiv
11461 !      call checkintcartgrad
11462       call zerograd
11463       aincr=1.0D-5
11464       write(iout,*) 'Calling CHECK_ECARTINT.'
11465       nf=0
11466       icall=0
11467       write (iout,*) "Before geom_to_var"
11468       call geom_to_var(nvar,x)
11469       write (iout,*) "after geom_to_var"
11470       write (iout,*) "split_ene ",split_ene
11471       call flush(iout)
11472       if (.not.split_ene) then
11473         write(iout,*) 'Calling CHECK_ECARTINT if'
11474         call etotal(energia)
11475 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11476         etot=energia(0)
11477         write (iout,*) "etot",etot
11478         call flush(iout)
11479 !el        call enerprint(energia)
11480 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11481         call flush(iout)
11482         write (iout,*) "enter cartgrad"
11483         call flush(iout)
11484         call cartgrad
11485 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11486         write (iout,*) "exit cartgrad"
11487         call flush(iout)
11488         icall =1
11489         do i=1,nres
11490           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11491         enddo
11492         do j=1,3
11493           grad_s(j,0)=gcart(j,0)
11494         enddo
11495 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11496         do i=1,nres
11497           do j=1,3
11498             grad_s(j,i)=gcart(j,i)
11499             grad_s(j+3,i)=gxcart(j,i)
11500           enddo
11501         enddo
11502       else
11503 write(iout,*) 'Calling CHECK_ECARTIN else.'
11504 !- split gradient check
11505         call zerograd
11506         call etotal_long(energia)
11507 !el        call enerprint(energia)
11508         call flush(iout)
11509         write (iout,*) "enter cartgrad"
11510         call flush(iout)
11511         call cartgrad
11512         write (iout,*) "exit cartgrad"
11513         call flush(iout)
11514         icall =1
11515         write (iout,*) "longrange grad"
11516         do i=1,nres
11517           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11518           (gxcart(j,i),j=1,3)
11519         enddo
11520         do j=1,3
11521           grad_s(j,0)=gcart(j,0)
11522         enddo
11523         do i=1,nres
11524           do j=1,3
11525             grad_s(j,i)=gcart(j,i)
11526             grad_s(j+3,i)=gxcart(j,i)
11527           enddo
11528         enddo
11529         call zerograd
11530         call etotal_short(energia)
11531 !el        call enerprint(energia)
11532         call flush(iout)
11533         write (iout,*) "enter cartgrad"
11534         call flush(iout)
11535         call cartgrad
11536         write (iout,*) "exit cartgrad"
11537         call flush(iout)
11538         icall =1
11539         write (iout,*) "shortrange grad"
11540         do i=1,nres
11541           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11542           (gxcart(j,i),j=1,3)
11543         enddo
11544         do j=1,3
11545           grad_s1(j,0)=gcart(j,0)
11546         enddo
11547         do i=1,nres
11548           do j=1,3
11549             grad_s1(j,i)=gcart(j,i)
11550             grad_s1(j+3,i)=gxcart(j,i)
11551           enddo
11552         enddo
11553       endif
11554       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11555 !      do i=1,nres
11556       do i=nnt,nct
11557         do j=1,3
11558           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11559           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11560           ddc(j)=c(j,i)
11561           ddx(j)=c(j,i+nres)
11562           dcnorm_safe1(j)=dc_norm(j,i-1)
11563           dcnorm_safe2(j)=dc_norm(j,i)
11564           dxnorm_safe(j)=dc_norm(j,i+nres)
11565         enddo
11566         do j=1,3
11567           c(j,i)=ddc(j)+aincr
11568           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11569           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11570           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11571           dc(j,i)=c(j,i+1)-c(j,i)
11572           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11573           call int_from_cart1(.false.)
11574           if (.not.split_ene) then
11575             call etotal(energia1)
11576             etot1=energia1(0)
11577             write (iout,*) "ij",i,j," etot1",etot1
11578           else
11579 !- split gradient
11580             call etotal_long(energia1)
11581             etot11=energia1(0)
11582             call etotal_short(energia1)
11583             etot12=energia1(0)
11584           endif
11585 !- end split gradient
11586 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11587           c(j,i)=ddc(j)-aincr
11588           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11589           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11590           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11591           dc(j,i)=c(j,i+1)-c(j,i)
11592           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11593           call int_from_cart1(.false.)
11594           if (.not.split_ene) then
11595             call etotal(energia1)
11596             etot2=energia1(0)
11597             write (iout,*) "ij",i,j," etot2",etot2
11598             ggg(j)=(etot1-etot2)/(2*aincr)
11599           else
11600 !- split gradient
11601             call etotal_long(energia1)
11602             etot21=energia1(0)
11603             ggg(j)=(etot11-etot21)/(2*aincr)
11604             call etotal_short(energia1)
11605             etot22=energia1(0)
11606             ggg1(j)=(etot12-etot22)/(2*aincr)
11607 !- end split gradient
11608 !            write (iout,*) "etot21",etot21," etot22",etot22
11609           endif
11610 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11611           c(j,i)=ddc(j)
11612           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11613           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11614           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11615           dc(j,i)=c(j,i+1)-c(j,i)
11616           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11617           dc_norm(j,i-1)=dcnorm_safe1(j)
11618           dc_norm(j,i)=dcnorm_safe2(j)
11619           dc_norm(j,i+nres)=dxnorm_safe(j)
11620         enddo
11621         do j=1,3
11622           c(j,i+nres)=ddx(j)+aincr
11623           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11624           call int_from_cart1(.false.)
11625           if (.not.split_ene) then
11626             call etotal(energia1)
11627             etot1=energia1(0)
11628           else
11629 !- split gradient
11630             call etotal_long(energia1)
11631             etot11=energia1(0)
11632             call etotal_short(energia1)
11633             etot12=energia1(0)
11634           endif
11635 !- end split gradient
11636           c(j,i+nres)=ddx(j)-aincr
11637           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11638           call int_from_cart1(.false.)
11639           if (.not.split_ene) then
11640             call etotal(energia1)
11641             etot2=energia1(0)
11642             ggg(j+3)=(etot1-etot2)/(2*aincr)
11643           else
11644 !- split gradient
11645             call etotal_long(energia1)
11646             etot21=energia1(0)
11647             ggg(j+3)=(etot11-etot21)/(2*aincr)
11648             call etotal_short(energia1)
11649             etot22=energia1(0)
11650             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11651 !- end split gradient
11652           endif
11653 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11654           c(j,i+nres)=ddx(j)
11655           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11656           dc_norm(j,i+nres)=dxnorm_safe(j)
11657           call int_from_cart1(.false.)
11658         enddo
11659         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11660          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11661         if (split_ene) then
11662           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11663          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11664          k=1,6)
11665          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11666          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11667          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11668         endif
11669       enddo
11670       return
11671       end subroutine check_ecartint
11672 #else
11673 !-----------------------------------------------------------------------------
11674       subroutine check_ecartint
11675 ! Check the gradient of the energy in Cartesian coordinates.
11676       use io_base, only: intout
11677 !      implicit real*8 (a-h,o-z)
11678 !      include 'DIMENSIONS'
11679 !      include 'COMMON.CONTROL'
11680 !      include 'COMMON.CHAIN'
11681 !      include 'COMMON.DERIV'
11682 !      include 'COMMON.IOUNITS'
11683 !      include 'COMMON.VAR'
11684 !      include 'COMMON.CONTACTS'
11685 !      include 'COMMON.MD'
11686 !      include 'COMMON.LOCAL'
11687 !      include 'COMMON.SPLITELE'
11688       use comm_srutu
11689 !el      integer :: icall
11690 !el      common /srutu/ icall
11691       real(kind=8),dimension(6) :: ggg,ggg1
11692       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11693       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11694       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
11695       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11696       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11697       real(kind=8),dimension(0:n_ene) :: energia,energia1
11698       integer :: uiparm(1)
11699       real(kind=8) :: urparm(1)
11700 !EL      external fdum
11701       integer :: i,j,k,nf
11702       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11703                    etot21,etot22
11704       r_cut=2.0d0
11705       rlambd=0.3d0
11706       icg=1
11707       nf=0
11708       nfl=0
11709       call intout
11710 !      call intcartderiv
11711 !      call checkintcartgrad
11712       call zerograd
11713       aincr=2.0D-5
11714       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
11715       nf=0
11716       icall=0
11717       call geom_to_var(nvar,x)
11718       if (.not.split_ene) then
11719         call etotal(energia)
11720         etot=energia(0)
11721 !el        call enerprint(energia)
11722         call flush(iout)
11723         write (iout,*) "enter cartgrad"
11724         call flush(iout)
11725         call cartgrad
11726         write (iout,*) "exit cartgrad"
11727         call flush(iout)
11728         icall =1
11729         do i=1,nres
11730           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11731         enddo
11732         do j=1,3
11733           grad_s(j,0)=gcart(j,0)
11734         enddo
11735         do i=1,nres
11736           do j=1,3
11737             grad_s(j,i)=gcart(j,i)
11738             grad_s(j+3,i)=gxcart(j,i)
11739           enddo
11740         enddo
11741       else
11742 !- split gradient check
11743         call zerograd
11744         call etotal_long(energia)
11745 !el        call enerprint(energia)
11746         call flush(iout)
11747         write (iout,*) "enter cartgrad"
11748         call flush(iout)
11749         call cartgrad
11750         write (iout,*) "exit cartgrad"
11751         call flush(iout)
11752         icall =1
11753         write (iout,*) "longrange grad"
11754         do i=1,nres
11755           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11756           (gxcart(j,i),j=1,3)
11757         enddo
11758         do j=1,3
11759           grad_s(j,0)=gcart(j,0)
11760         enddo
11761         do i=1,nres
11762           do j=1,3
11763             grad_s(j,i)=gcart(j,i)
11764             grad_s(j+3,i)=gxcart(j,i)
11765           enddo
11766         enddo
11767         call zerograd
11768         call etotal_short(energia)
11769 !el        call enerprint(energia)
11770         call flush(iout)
11771         write (iout,*) "enter cartgrad"
11772         call flush(iout)
11773         call cartgrad
11774         write (iout,*) "exit cartgrad"
11775         call flush(iout)
11776         icall =1
11777         write (iout,*) "shortrange grad"
11778         do i=1,nres
11779           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11780           (gxcart(j,i),j=1,3)
11781         enddo
11782         do j=1,3
11783           grad_s1(j,0)=gcart(j,0)
11784         enddo
11785         do i=1,nres
11786           do j=1,3
11787             grad_s1(j,i)=gcart(j,i)
11788             grad_s1(j+3,i)=gxcart(j,i)
11789           enddo
11790         enddo
11791       endif
11792       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11793       do i=0,nres
11794         do j=1,3
11795           xx(j)=c(j,i+nres)
11796           ddc(j)=dc(j,i)
11797           ddx(j)=dc(j,i+nres)
11798           do k=1,3
11799             dcnorm_safe(k)=dc_norm(k,i)
11800             dxnorm_safe(k)=dc_norm(k,i+nres)
11801           enddo
11802         enddo
11803         do j=1,3
11804           dc(j,i)=ddc(j)+aincr
11805           call chainbuild_cart
11806 #ifdef MPI
11807 ! Broadcast the order to compute internal coordinates to the slaves.
11808 !          if (nfgtasks.gt.1)
11809 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
11810 #endif
11811 !          call int_from_cart1(.false.)
11812           if (.not.split_ene) then
11813             call etotal(energia1)
11814             etot1=energia1(0)
11815           else
11816 !- split gradient
11817             call etotal_long(energia1)
11818             etot11=energia1(0)
11819             call etotal_short(energia1)
11820             etot12=energia1(0)
11821 !            write (iout,*) "etot11",etot11," etot12",etot12
11822           endif
11823 !- end split gradient
11824 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11825           dc(j,i)=ddc(j)-aincr
11826           call chainbuild_cart
11827 !          call int_from_cart1(.false.)
11828           if (.not.split_ene) then
11829             call etotal(energia1)
11830             etot2=energia1(0)
11831             ggg(j)=(etot1-etot2)/(2*aincr)
11832           else
11833 !- split gradient
11834             call etotal_long(energia1)
11835             etot21=energia1(0)
11836             ggg(j)=(etot11-etot21)/(2*aincr)
11837             call etotal_short(energia1)
11838             etot22=energia1(0)
11839             ggg1(j)=(etot12-etot22)/(2*aincr)
11840 !- end split gradient
11841 !            write (iout,*) "etot21",etot21," etot22",etot22
11842           endif
11843 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11844           dc(j,i)=ddc(j)
11845           call chainbuild_cart
11846         enddo
11847         do j=1,3
11848           dc(j,i+nres)=ddx(j)+aincr
11849           call chainbuild_cart
11850 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
11851 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11852 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11853 !          write (iout,*) "dxnormnorm",dsqrt(
11854 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11855 !          write (iout,*) "dxnormnormsafe",dsqrt(
11856 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11857 !          write (iout,*)
11858           if (.not.split_ene) then
11859             call etotal(energia1)
11860             etot1=energia1(0)
11861           else
11862 !- split gradient
11863             call etotal_long(energia1)
11864             etot11=energia1(0)
11865             call etotal_short(energia1)
11866             etot12=energia1(0)
11867           endif
11868 !- end split gradient
11869 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11870           dc(j,i+nres)=ddx(j)-aincr
11871           call chainbuild_cart
11872 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
11873 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11874 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11875 !          write (iout,*)
11876 !          write (iout,*) "dxnormnorm",dsqrt(
11877 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11878 !          write (iout,*) "dxnormnormsafe",dsqrt(
11879 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11880           if (.not.split_ene) then
11881             call etotal(energia1)
11882             etot2=energia1(0)
11883             ggg(j+3)=(etot1-etot2)/(2*aincr)
11884           else
11885 !- split gradient
11886             call etotal_long(energia1)
11887             etot21=energia1(0)
11888             ggg(j+3)=(etot11-etot21)/(2*aincr)
11889             call etotal_short(energia1)
11890             etot22=energia1(0)
11891             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11892 !- end split gradient
11893           endif
11894 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11895           dc(j,i+nres)=ddx(j)
11896           call chainbuild_cart
11897         enddo
11898         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11899          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11900         if (split_ene) then
11901           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11902          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11903          k=1,6)
11904          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11905          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11906          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11907         endif
11908       enddo
11909       return
11910       end subroutine check_ecartint
11911 #endif
11912 !-----------------------------------------------------------------------------
11913       subroutine check_eint
11914 ! Check the gradient of energy in internal coordinates.
11915 !      implicit real*8 (a-h,o-z)
11916 !      include 'DIMENSIONS'
11917 !      include 'COMMON.CHAIN'
11918 !      include 'COMMON.DERIV'
11919 !      include 'COMMON.IOUNITS'
11920 !      include 'COMMON.VAR'
11921 !      include 'COMMON.GEO'
11922       use comm_srutu
11923 !el      integer :: icall
11924 !el      common /srutu/ icall
11925       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
11926       integer :: uiparm(1)
11927       real(kind=8) :: urparm(1)
11928       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
11929       character(len=6) :: key
11930 !EL      external fdum
11931       integer :: i,ii,nf
11932       real(kind=8) :: xi,aincr,etot,etot1,etot2
11933       call zerograd
11934       aincr=1.0D-7
11935       print '(a)','Calling CHECK_INT.'
11936       nf=0
11937       nfl=0
11938       icg=1
11939       call geom_to_var(nvar,x)
11940       call var_to_geom(nvar,x)
11941       call chainbuild
11942       icall=1
11943       print *,'ICG=',ICG
11944       call etotal(energia)
11945       etot = energia(0)
11946 !el      call enerprint(energia)
11947       print *,'ICG=',ICG
11948 #ifdef MPL
11949       if (MyID.ne.BossID) then
11950         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
11951         nf=x(nvar+1)
11952         nfl=x(nvar+2)
11953         icg=x(nvar+3)
11954       endif
11955 #endif
11956       nf=1
11957       nfl=3
11958 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
11959       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
11960 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
11961       icall=1
11962       do i=1,nvar
11963         xi=x(i)
11964         x(i)=xi-0.5D0*aincr
11965         call var_to_geom(nvar,x)
11966         call chainbuild
11967         call etotal(energia1)
11968         etot1=energia1(0)
11969         x(i)=xi+0.5D0*aincr
11970         call var_to_geom(nvar,x)
11971         call chainbuild
11972         call etotal(energia2)
11973         etot2=energia2(0)
11974         gg(i)=(etot2-etot1)/aincr
11975         write (iout,*) i,etot1,etot2
11976         x(i)=xi
11977       enddo
11978       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
11979           '     RelDiff*100% '
11980       do i=1,nvar
11981         if (i.le.nphi) then
11982           ii=i
11983           key = ' phi'
11984         else if (i.le.nphi+ntheta) then
11985           ii=i-nphi
11986           key=' theta'
11987         else if (i.le.nphi+ntheta+nside) then
11988            ii=i-(nphi+ntheta)
11989            key=' alpha'
11990         else
11991            ii=i-(nphi+ntheta+nside)
11992            key=' omega'
11993         endif
11994         write (iout,'(i3,a,i3,3(1pd16.6))') &
11995        i,key,ii,gg(i),gana(i),&
11996        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
11997       enddo
11998       return
11999       end subroutine check_eint
12000 !-----------------------------------------------------------------------------
12001 ! econstr_local.F
12002 !-----------------------------------------------------------------------------
12003       subroutine Econstr_back
12004 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12005 !      implicit real*8 (a-h,o-z)
12006 !      include 'DIMENSIONS'
12007 !      include 'COMMON.CONTROL'
12008 !      include 'COMMON.VAR'
12009 !      include 'COMMON.MD'
12010       use MD_data
12011 !#ifndef LANG0
12012 !      include 'COMMON.LANGEVIN'
12013 !#else
12014 !      include 'COMMON.LANGEVIN.lang0'
12015 !#endif
12016 !      include 'COMMON.CHAIN'
12017 !      include 'COMMON.DERIV'
12018 !      include 'COMMON.GEO'
12019 !      include 'COMMON.LOCAL'
12020 !      include 'COMMON.INTERACT'
12021 !      include 'COMMON.IOUNITS'
12022 !      include 'COMMON.NAMES'
12023 !      include 'COMMON.TIME1'
12024       integer :: i,j,ii,k
12025       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12026
12027       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12028       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12029       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12030
12031       Uconst_back=0.0d0
12032       do i=1,nres
12033         dutheta(i)=0.0d0
12034         dugamma(i)=0.0d0
12035         do j=1,3
12036           duscdiff(j,i)=0.0d0
12037           duscdiffx(j,i)=0.0d0
12038         enddo
12039       enddo
12040       do i=1,nfrag_back
12041         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12042 !
12043 ! Deviations from theta angles
12044 !
12045         utheta_i=0.0d0
12046         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12047           dtheta_i=theta(j)-thetaref(j)
12048           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12049           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12050         enddo
12051         utheta(i)=utheta_i/(ii-1)
12052 !
12053 ! Deviations from gamma angles
12054 !
12055         ugamma_i=0.0d0
12056         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12057           dgamma_i=pinorm(phi(j)-phiref(j))
12058 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12059           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12060           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12061 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12062         enddo
12063         ugamma(i)=ugamma_i/(ii-2)
12064 !
12065 ! Deviations from local SC geometry
12066 !
12067         uscdiff(i)=0.0d0
12068         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12069           dxx=xxtab(j)-xxref(j)
12070           dyy=yytab(j)-yyref(j)
12071           dzz=zztab(j)-zzref(j)
12072           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12073           do k=1,3
12074             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12075              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12076              (ii-1)
12077             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12078              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12079              (ii-1)
12080             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12081            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12082             /(ii-1)
12083           enddo
12084 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12085 !     &      xxref(j),yyref(j),zzref(j)
12086         enddo
12087         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12088 !        write (iout,*) i," uscdiff",uscdiff(i)
12089 !
12090 ! Put together deviations from local geometry
12091 !
12092         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12093           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12094 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12095 !     &   " uconst_back",uconst_back
12096         utheta(i)=dsqrt(utheta(i))
12097         ugamma(i)=dsqrt(ugamma(i))
12098         uscdiff(i)=dsqrt(uscdiff(i))
12099       enddo
12100       return
12101       end subroutine Econstr_back
12102 !-----------------------------------------------------------------------------
12103 ! energy_p_new-sep_barrier.F
12104 !-----------------------------------------------------------------------------
12105       real(kind=8) function sscale(r)
12106 !      include "COMMON.SPLITELE"
12107       real(kind=8) :: r,gamm
12108       if(r.lt.r_cut-rlamb) then
12109         sscale=1.0d0
12110       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12111         gamm=(r-(r_cut-rlamb))/rlamb
12112         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12113       else
12114         sscale=0d0
12115       endif
12116       return
12117       end function sscale
12118       real(kind=8) function sscale_grad(r)
12119 !      include "COMMON.SPLITELE"
12120       real(kind=8) :: r,gamm
12121       if(r.lt.r_cut-rlamb) then
12122         sscale_grad=0.0d0
12123       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12124         gamm=(r-(r_cut-rlamb))/rlamb
12125         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12126       else
12127         sscale_grad=0d0
12128       endif
12129       return
12130       end function sscale_grad
12131
12132 !!!!!!!!!! PBCSCALE
12133       real(kind=8) function sscale_ele(r)
12134 !      include "COMMON.SPLITELE"
12135       real(kind=8) :: r,gamm
12136       if(r.lt.r_cut_ele-rlamb_ele) then
12137         sscale_ele=1.0d0
12138       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12139         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12140         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12141       else
12142         sscale_ele=0d0
12143       endif
12144       return
12145       end function sscale_ele
12146
12147       real(kind=8)  function sscagrad_ele(r)
12148       real(kind=8) :: r,gamm
12149 !      include "COMMON.SPLITELE"
12150       if(r.lt.r_cut_ele-rlamb_ele) then
12151         sscagrad_ele=0.0d0
12152       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12153         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12154         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12155       else
12156         sscagrad_ele=0.0d0
12157       endif
12158       return
12159       end function sscagrad_ele
12160       real(kind=8) function sscalelip(r)
12161       real(kind=8) r,gamm
12162         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12163       return
12164       end function sscalelip
12165 !C-----------------------------------------------------------------------
12166       real(kind=8) function sscagradlip(r)
12167       real(kind=8) r,gamm
12168         sscagradlip=r*(6.0d0*r-6.0d0)
12169       return
12170       end function sscagradlip
12171
12172 !!!!!!!!!!!!!!!
12173 !-----------------------------------------------------------------------------
12174       subroutine elj_long(evdw)
12175 !
12176 ! This subroutine calculates the interaction energy of nonbonded side chains
12177 ! assuming the LJ potential of interaction.
12178 !
12179 !      implicit real*8 (a-h,o-z)
12180 !      include 'DIMENSIONS'
12181 !      include 'COMMON.GEO'
12182 !      include 'COMMON.VAR'
12183 !      include 'COMMON.LOCAL'
12184 !      include 'COMMON.CHAIN'
12185 !      include 'COMMON.DERIV'
12186 !      include 'COMMON.INTERACT'
12187 !      include 'COMMON.TORSION'
12188 !      include 'COMMON.SBRIDGE'
12189 !      include 'COMMON.NAMES'
12190 !      include 'COMMON.IOUNITS'
12191 !      include 'COMMON.CONTACTS'
12192       real(kind=8),parameter :: accur=1.0d-10
12193       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12194 !el local variables
12195       integer :: i,iint,j,k,itypi,itypi1,itypj
12196       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12197       real(kind=8) :: e1,e2,evdwij,evdw
12198 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12199       evdw=0.0D0
12200       do i=iatsc_s,iatsc_e
12201         itypi=itype(i,1)
12202         if (itypi.eq.ntyp1) cycle
12203         itypi1=itype(i+1,1)
12204         xi=c(1,nres+i)
12205         yi=c(2,nres+i)
12206         zi=c(3,nres+i)
12207 !
12208 ! Calculate SC interaction energy.
12209 !
12210         do iint=1,nint_gr(i)
12211 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12212 !d   &                  'iend=',iend(i,iint)
12213           do j=istart(i,iint),iend(i,iint)
12214             itypj=itype(j,1)
12215             if (itypj.eq.ntyp1) cycle
12216             xj=c(1,nres+j)-xi
12217             yj=c(2,nres+j)-yi
12218             zj=c(3,nres+j)-zi
12219             rij=xj*xj+yj*yj+zj*zj
12220             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12221             if (sss.lt.1.0d0) then
12222               rrij=1.0D0/rij
12223               eps0ij=eps(itypi,itypj)
12224               fac=rrij**expon2
12225               e1=fac*fac*aa_aq(itypi,itypj)
12226               e2=fac*bb_aq(itypi,itypj)
12227               evdwij=e1+e2
12228               evdw=evdw+(1.0d0-sss)*evdwij
12229 !
12230 ! Calculate the components of the gradient in DC and X
12231 !
12232               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12233               gg(1)=xj*fac
12234               gg(2)=yj*fac
12235               gg(3)=zj*fac
12236               do k=1,3
12237                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12238                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12239                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12240                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12241               enddo
12242             endif
12243           enddo      ! j
12244         enddo        ! iint
12245       enddo          ! i
12246       do i=1,nct
12247         do j=1,3
12248           gvdwc(j,i)=expon*gvdwc(j,i)
12249           gvdwx(j,i)=expon*gvdwx(j,i)
12250         enddo
12251       enddo
12252 !******************************************************************************
12253 !
12254 !                              N O T E !!!
12255 !
12256 ! To save time, the factor of EXPON has been extracted from ALL components
12257 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12258 ! use!
12259 !
12260 !******************************************************************************
12261       return
12262       end subroutine elj_long
12263 !-----------------------------------------------------------------------------
12264       subroutine elj_short(evdw)
12265 !
12266 ! This subroutine calculates the interaction energy of nonbonded side chains
12267 ! assuming the LJ potential of interaction.
12268 !
12269 !      implicit real*8 (a-h,o-z)
12270 !      include 'DIMENSIONS'
12271 !      include 'COMMON.GEO'
12272 !      include 'COMMON.VAR'
12273 !      include 'COMMON.LOCAL'
12274 !      include 'COMMON.CHAIN'
12275 !      include 'COMMON.DERIV'
12276 !      include 'COMMON.INTERACT'
12277 !      include 'COMMON.TORSION'
12278 !      include 'COMMON.SBRIDGE'
12279 !      include 'COMMON.NAMES'
12280 !      include 'COMMON.IOUNITS'
12281 !      include 'COMMON.CONTACTS'
12282       real(kind=8),parameter :: accur=1.0d-10
12283       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12284 !el local variables
12285       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12286       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12287       real(kind=8) :: e1,e2,evdwij,evdw
12288 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12289       evdw=0.0D0
12290       do i=iatsc_s,iatsc_e
12291         itypi=itype(i,1)
12292         if (itypi.eq.ntyp1) cycle
12293         itypi1=itype(i+1,1)
12294         xi=c(1,nres+i)
12295         yi=c(2,nres+i)
12296         zi=c(3,nres+i)
12297 ! Change 12/1/95
12298         num_conti=0
12299 !
12300 ! Calculate SC interaction energy.
12301 !
12302         do iint=1,nint_gr(i)
12303 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12304 !d   &                  'iend=',iend(i,iint)
12305           do j=istart(i,iint),iend(i,iint)
12306             itypj=itype(j,1)
12307             if (itypj.eq.ntyp1) cycle
12308             xj=c(1,nres+j)-xi
12309             yj=c(2,nres+j)-yi
12310             zj=c(3,nres+j)-zi
12311 ! Change 12/1/95 to calculate four-body interactions
12312             rij=xj*xj+yj*yj+zj*zj
12313             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12314             if (sss.gt.0.0d0) then
12315               rrij=1.0D0/rij
12316               eps0ij=eps(itypi,itypj)
12317               fac=rrij**expon2
12318               e1=fac*fac*aa_aq(itypi,itypj)
12319               e2=fac*bb_aq(itypi,itypj)
12320               evdwij=e1+e2
12321               evdw=evdw+sss*evdwij
12322 !
12323 ! Calculate the components of the gradient in DC and X
12324 !
12325               fac=-rrij*(e1+evdwij)*sss
12326               gg(1)=xj*fac
12327               gg(2)=yj*fac
12328               gg(3)=zj*fac
12329               do k=1,3
12330                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12331                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12332                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12333                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12334               enddo
12335             endif
12336           enddo      ! j
12337         enddo        ! iint
12338       enddo          ! i
12339       do i=1,nct
12340         do j=1,3
12341           gvdwc(j,i)=expon*gvdwc(j,i)
12342           gvdwx(j,i)=expon*gvdwx(j,i)
12343         enddo
12344       enddo
12345 !******************************************************************************
12346 !
12347 !                              N O T E !!!
12348 !
12349 ! To save time, the factor of EXPON has been extracted from ALL components
12350 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12351 ! use!
12352 !
12353 !******************************************************************************
12354       return
12355       end subroutine elj_short
12356 !-----------------------------------------------------------------------------
12357       subroutine eljk_long(evdw)
12358 !
12359 ! This subroutine calculates the interaction energy of nonbonded side chains
12360 ! assuming the LJK potential of interaction.
12361 !
12362 !      implicit real*8 (a-h,o-z)
12363 !      include 'DIMENSIONS'
12364 !      include 'COMMON.GEO'
12365 !      include 'COMMON.VAR'
12366 !      include 'COMMON.LOCAL'
12367 !      include 'COMMON.CHAIN'
12368 !      include 'COMMON.DERIV'
12369 !      include 'COMMON.INTERACT'
12370 !      include 'COMMON.IOUNITS'
12371 !      include 'COMMON.NAMES'
12372       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12373       logical :: scheck
12374 !el local variables
12375       integer :: i,iint,j,k,itypi,itypi1,itypj
12376       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12377                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12378 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12379       evdw=0.0D0
12380       do i=iatsc_s,iatsc_e
12381         itypi=itype(i,1)
12382         if (itypi.eq.ntyp1) cycle
12383         itypi1=itype(i+1,1)
12384         xi=c(1,nres+i)
12385         yi=c(2,nres+i)
12386         zi=c(3,nres+i)
12387 !
12388 ! Calculate SC interaction energy.
12389 !
12390         do iint=1,nint_gr(i)
12391           do j=istart(i,iint),iend(i,iint)
12392             itypj=itype(j,1)
12393             if (itypj.eq.ntyp1) cycle
12394             xj=c(1,nres+j)-xi
12395             yj=c(2,nres+j)-yi
12396             zj=c(3,nres+j)-zi
12397             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12398             fac_augm=rrij**expon
12399             e_augm=augm(itypi,itypj)*fac_augm
12400             r_inv_ij=dsqrt(rrij)
12401             rij=1.0D0/r_inv_ij
12402             sss=sscale(rij/sigma(itypi,itypj))
12403             if (sss.lt.1.0d0) then
12404               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12405               fac=r_shift_inv**expon
12406               e1=fac*fac*aa_aq(itypi,itypj)
12407               e2=fac*bb_aq(itypi,itypj)
12408               evdwij=e_augm+e1+e2
12409 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12410 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12411 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12412 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12413 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12414 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12415 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12416               evdw=evdw+(1.0d0-sss)*evdwij
12417 !
12418 ! Calculate the components of the gradient in DC and X
12419 !
12420               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12421               fac=fac*(1.0d0-sss)
12422               gg(1)=xj*fac
12423               gg(2)=yj*fac
12424               gg(3)=zj*fac
12425               do k=1,3
12426                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12427                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12428                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12429                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12430               enddo
12431             endif
12432           enddo      ! j
12433         enddo        ! iint
12434       enddo          ! i
12435       do i=1,nct
12436         do j=1,3
12437           gvdwc(j,i)=expon*gvdwc(j,i)
12438           gvdwx(j,i)=expon*gvdwx(j,i)
12439         enddo
12440       enddo
12441       return
12442       end subroutine eljk_long
12443 !-----------------------------------------------------------------------------
12444       subroutine eljk_short(evdw)
12445 !
12446 ! This subroutine calculates the interaction energy of nonbonded side chains
12447 ! assuming the LJK potential of interaction.
12448 !
12449 !      implicit real*8 (a-h,o-z)
12450 !      include 'DIMENSIONS'
12451 !      include 'COMMON.GEO'
12452 !      include 'COMMON.VAR'
12453 !      include 'COMMON.LOCAL'
12454 !      include 'COMMON.CHAIN'
12455 !      include 'COMMON.DERIV'
12456 !      include 'COMMON.INTERACT'
12457 !      include 'COMMON.IOUNITS'
12458 !      include 'COMMON.NAMES'
12459       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12460       logical :: scheck
12461 !el local variables
12462       integer :: i,iint,j,k,itypi,itypi1,itypj
12463       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12464                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12465 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12466       evdw=0.0D0
12467       do i=iatsc_s,iatsc_e
12468         itypi=itype(i,1)
12469         if (itypi.eq.ntyp1) cycle
12470         itypi1=itype(i+1,1)
12471         xi=c(1,nres+i)
12472         yi=c(2,nres+i)
12473         zi=c(3,nres+i)
12474 !
12475 ! Calculate SC interaction energy.
12476 !
12477         do iint=1,nint_gr(i)
12478           do j=istart(i,iint),iend(i,iint)
12479             itypj=itype(j,1)
12480             if (itypj.eq.ntyp1) cycle
12481             xj=c(1,nres+j)-xi
12482             yj=c(2,nres+j)-yi
12483             zj=c(3,nres+j)-zi
12484             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12485             fac_augm=rrij**expon
12486             e_augm=augm(itypi,itypj)*fac_augm
12487             r_inv_ij=dsqrt(rrij)
12488             rij=1.0D0/r_inv_ij
12489             sss=sscale(rij/sigma(itypi,itypj))
12490             if (sss.gt.0.0d0) then
12491               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12492               fac=r_shift_inv**expon
12493               e1=fac*fac*aa_aq(itypi,itypj)
12494               e2=fac*bb_aq(itypi,itypj)
12495               evdwij=e_augm+e1+e2
12496 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12497 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12498 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12499 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12500 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12501 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12502 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12503               evdw=evdw+sss*evdwij
12504 !
12505 ! Calculate the components of the gradient in DC and X
12506 !
12507               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12508               fac=fac*sss
12509               gg(1)=xj*fac
12510               gg(2)=yj*fac
12511               gg(3)=zj*fac
12512               do k=1,3
12513                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12514                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12515                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12516                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12517               enddo
12518             endif
12519           enddo      ! j
12520         enddo        ! iint
12521       enddo          ! i
12522       do i=1,nct
12523         do j=1,3
12524           gvdwc(j,i)=expon*gvdwc(j,i)
12525           gvdwx(j,i)=expon*gvdwx(j,i)
12526         enddo
12527       enddo
12528       return
12529       end subroutine eljk_short
12530 !-----------------------------------------------------------------------------
12531       subroutine ebp_long(evdw)
12532 !
12533 ! This subroutine calculates the interaction energy of nonbonded side chains
12534 ! assuming the Berne-Pechukas potential of interaction.
12535 !
12536       use calc_data
12537 !      implicit real*8 (a-h,o-z)
12538 !      include 'DIMENSIONS'
12539 !      include 'COMMON.GEO'
12540 !      include 'COMMON.VAR'
12541 !      include 'COMMON.LOCAL'
12542 !      include 'COMMON.CHAIN'
12543 !      include 'COMMON.DERIV'
12544 !      include 'COMMON.NAMES'
12545 !      include 'COMMON.INTERACT'
12546 !      include 'COMMON.IOUNITS'
12547 !      include 'COMMON.CALC'
12548       use comm_srutu
12549 !el      integer :: icall
12550 !el      common /srutu/ icall
12551 !     double precision rrsave(maxdim)
12552       logical :: lprn
12553 !el local variables
12554       integer :: iint,itypi,itypi1,itypj
12555       real(kind=8) :: rrij,xi,yi,zi,fac
12556       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12557       evdw=0.0D0
12558 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12559       evdw=0.0D0
12560 !     if (icall.eq.0) then
12561 !       lprn=.true.
12562 !     else
12563         lprn=.false.
12564 !     endif
12565 !el      ind=0
12566       do i=iatsc_s,iatsc_e
12567         itypi=itype(i,1)
12568         if (itypi.eq.ntyp1) cycle
12569         itypi1=itype(i+1,1)
12570         xi=c(1,nres+i)
12571         yi=c(2,nres+i)
12572         zi=c(3,nres+i)
12573         dxi=dc_norm(1,nres+i)
12574         dyi=dc_norm(2,nres+i)
12575         dzi=dc_norm(3,nres+i)
12576 !        dsci_inv=dsc_inv(itypi)
12577         dsci_inv=vbld_inv(i+nres)
12578 !
12579 ! Calculate SC interaction energy.
12580 !
12581         do iint=1,nint_gr(i)
12582           do j=istart(i,iint),iend(i,iint)
12583 !el            ind=ind+1
12584             itypj=itype(j,1)
12585             if (itypj.eq.ntyp1) cycle
12586 !            dscj_inv=dsc_inv(itypj)
12587             dscj_inv=vbld_inv(j+nres)
12588             chi1=chi(itypi,itypj)
12589             chi2=chi(itypj,itypi)
12590             chi12=chi1*chi2
12591             chip1=chip(itypi)
12592             chip2=chip(itypj)
12593             chip12=chip1*chip2
12594             alf1=alp(itypi)
12595             alf2=alp(itypj)
12596             alf12=0.5D0*(alf1+alf2)
12597             xj=c(1,nres+j)-xi
12598             yj=c(2,nres+j)-yi
12599             zj=c(3,nres+j)-zi
12600             dxj=dc_norm(1,nres+j)
12601             dyj=dc_norm(2,nres+j)
12602             dzj=dc_norm(3,nres+j)
12603             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12604             rij=dsqrt(rrij)
12605             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12606
12607             if (sss.lt.1.0d0) then
12608
12609 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12610               call sc_angular
12611 ! Calculate whole angle-dependent part of epsilon and contributions
12612 ! to its derivatives
12613               fac=(rrij*sigsq)**expon2
12614               e1=fac*fac*aa_aq(itypi,itypj)
12615               e2=fac*bb_aq(itypi,itypj)
12616               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12617               eps2der=evdwij*eps3rt
12618               eps3der=evdwij*eps2rt
12619               evdwij=evdwij*eps2rt*eps3rt
12620               evdw=evdw+evdwij*(1.0d0-sss)
12621               if (lprn) then
12622               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12623               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12624 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12625 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12626 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12627 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12628 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12629 !d     &          evdwij
12630               endif
12631 ! Calculate gradient components.
12632               e1=e1*eps1*eps2rt**2*eps3rt**2
12633               fac=-expon*(e1+evdwij)
12634               sigder=fac/sigsq
12635               fac=rrij*fac
12636 ! Calculate radial part of the gradient
12637               gg(1)=xj*fac
12638               gg(2)=yj*fac
12639               gg(3)=zj*fac
12640 ! Calculate the angular part of the gradient and sum add the contributions
12641 ! to the appropriate components of the Cartesian gradient.
12642               call sc_grad_scale(1.0d0-sss)
12643             endif
12644           enddo      ! j
12645         enddo        ! iint
12646       enddo          ! i
12647 !     stop
12648       return
12649       end subroutine ebp_long
12650 !-----------------------------------------------------------------------------
12651       subroutine ebp_short(evdw)
12652 !
12653 ! This subroutine calculates the interaction energy of nonbonded side chains
12654 ! assuming the Berne-Pechukas potential of interaction.
12655 !
12656       use calc_data
12657 !      implicit real*8 (a-h,o-z)
12658 !      include 'DIMENSIONS'
12659 !      include 'COMMON.GEO'
12660 !      include 'COMMON.VAR'
12661 !      include 'COMMON.LOCAL'
12662 !      include 'COMMON.CHAIN'
12663 !      include 'COMMON.DERIV'
12664 !      include 'COMMON.NAMES'
12665 !      include 'COMMON.INTERACT'
12666 !      include 'COMMON.IOUNITS'
12667 !      include 'COMMON.CALC'
12668       use comm_srutu
12669 !el      integer :: icall
12670 !el      common /srutu/ icall
12671 !     double precision rrsave(maxdim)
12672       logical :: lprn
12673 !el local variables
12674       integer :: iint,itypi,itypi1,itypj
12675       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12676       real(kind=8) :: sss,e1,e2,evdw
12677       evdw=0.0D0
12678 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12679       evdw=0.0D0
12680 !     if (icall.eq.0) then
12681 !       lprn=.true.
12682 !     else
12683         lprn=.false.
12684 !     endif
12685 !el      ind=0
12686       do i=iatsc_s,iatsc_e
12687         itypi=itype(i,1)
12688         if (itypi.eq.ntyp1) cycle
12689         itypi1=itype(i+1,1)
12690         xi=c(1,nres+i)
12691         yi=c(2,nres+i)
12692         zi=c(3,nres+i)
12693         dxi=dc_norm(1,nres+i)
12694         dyi=dc_norm(2,nres+i)
12695         dzi=dc_norm(3,nres+i)
12696 !        dsci_inv=dsc_inv(itypi)
12697         dsci_inv=vbld_inv(i+nres)
12698 !
12699 ! Calculate SC interaction energy.
12700 !
12701         do iint=1,nint_gr(i)
12702           do j=istart(i,iint),iend(i,iint)
12703 !el            ind=ind+1
12704             itypj=itype(j,1)
12705             if (itypj.eq.ntyp1) cycle
12706 !            dscj_inv=dsc_inv(itypj)
12707             dscj_inv=vbld_inv(j+nres)
12708             chi1=chi(itypi,itypj)
12709             chi2=chi(itypj,itypi)
12710             chi12=chi1*chi2
12711             chip1=chip(itypi)
12712             chip2=chip(itypj)
12713             chip12=chip1*chip2
12714             alf1=alp(itypi)
12715             alf2=alp(itypj)
12716             alf12=0.5D0*(alf1+alf2)
12717             xj=c(1,nres+j)-xi
12718             yj=c(2,nres+j)-yi
12719             zj=c(3,nres+j)-zi
12720             dxj=dc_norm(1,nres+j)
12721             dyj=dc_norm(2,nres+j)
12722             dzj=dc_norm(3,nres+j)
12723             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12724             rij=dsqrt(rrij)
12725             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12726
12727             if (sss.gt.0.0d0) then
12728
12729 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12730               call sc_angular
12731 ! Calculate whole angle-dependent part of epsilon and contributions
12732 ! to its derivatives
12733               fac=(rrij*sigsq)**expon2
12734               e1=fac*fac*aa_aq(itypi,itypj)
12735               e2=fac*bb_aq(itypi,itypj)
12736               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12737               eps2der=evdwij*eps3rt
12738               eps3der=evdwij*eps2rt
12739               evdwij=evdwij*eps2rt*eps3rt
12740               evdw=evdw+evdwij*sss
12741               if (lprn) then
12742               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12743               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12744 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12745 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12746 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12747 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12748 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12749 !d     &          evdwij
12750               endif
12751 ! Calculate gradient components.
12752               e1=e1*eps1*eps2rt**2*eps3rt**2
12753               fac=-expon*(e1+evdwij)
12754               sigder=fac/sigsq
12755               fac=rrij*fac
12756 ! Calculate radial part of the gradient
12757               gg(1)=xj*fac
12758               gg(2)=yj*fac
12759               gg(3)=zj*fac
12760 ! Calculate the angular part of the gradient and sum add the contributions
12761 ! to the appropriate components of the Cartesian gradient.
12762               call sc_grad_scale(sss)
12763             endif
12764           enddo      ! j
12765         enddo        ! iint
12766       enddo          ! i
12767 !     stop
12768       return
12769       end subroutine ebp_short
12770 !-----------------------------------------------------------------------------
12771       subroutine egb_long(evdw)
12772 !
12773 ! This subroutine calculates the interaction energy of nonbonded side chains
12774 ! assuming the Gay-Berne potential of interaction.
12775 !
12776       use calc_data
12777 !      implicit real*8 (a-h,o-z)
12778 !      include 'DIMENSIONS'
12779 !      include 'COMMON.GEO'
12780 !      include 'COMMON.VAR'
12781 !      include 'COMMON.LOCAL'
12782 !      include 'COMMON.CHAIN'
12783 !      include 'COMMON.DERIV'
12784 !      include 'COMMON.NAMES'
12785 !      include 'COMMON.INTERACT'
12786 !      include 'COMMON.IOUNITS'
12787 !      include 'COMMON.CALC'
12788 !      include 'COMMON.CONTROL'
12789       logical :: lprn
12790 !el local variables
12791       integer :: iint,itypi,itypi1,itypj,subchap
12792       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
12793       real(kind=8) :: sss,e1,e2,evdw,sss_grad
12794       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
12795                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
12796                     ssgradlipi,ssgradlipj
12797
12798
12799       evdw=0.0D0
12800 !cccc      energy_dec=.false.
12801 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12802       evdw=0.0D0
12803       lprn=.false.
12804 !     if (icall.eq.0) lprn=.false.
12805 !el      ind=0
12806       do i=iatsc_s,iatsc_e
12807         itypi=itype(i,1)
12808         if (itypi.eq.ntyp1) cycle
12809         itypi1=itype(i+1,1)
12810         xi=c(1,nres+i)
12811         yi=c(2,nres+i)
12812         zi=c(3,nres+i)
12813           xi=mod(xi,boxxsize)
12814           if (xi.lt.0) xi=xi+boxxsize
12815           yi=mod(yi,boxysize)
12816           if (yi.lt.0) yi=yi+boxysize
12817           zi=mod(zi,boxzsize)
12818           if (zi.lt.0) zi=zi+boxzsize
12819        if ((zi.gt.bordlipbot)    &
12820         .and.(zi.lt.bordliptop)) then
12821 !C the energy transfer exist
12822         if (zi.lt.buflipbot) then
12823 !C what fraction I am in
12824          fracinbuf=1.0d0-    &
12825              ((zi-bordlipbot)/lipbufthick)
12826 !C lipbufthick is thickenes of lipid buffore
12827          sslipi=sscalelip(fracinbuf)
12828          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
12829         elseif (zi.gt.bufliptop) then
12830          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
12831          sslipi=sscalelip(fracinbuf)
12832          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
12833         else
12834          sslipi=1.0d0
12835          ssgradlipi=0.0
12836         endif
12837        else
12838          sslipi=0.0d0
12839          ssgradlipi=0.0
12840        endif
12841
12842         dxi=dc_norm(1,nres+i)
12843         dyi=dc_norm(2,nres+i)
12844         dzi=dc_norm(3,nres+i)
12845 !        dsci_inv=dsc_inv(itypi)
12846         dsci_inv=vbld_inv(i+nres)
12847 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
12848 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
12849 !
12850 ! Calculate SC interaction energy.
12851 !
12852         do iint=1,nint_gr(i)
12853           do j=istart(i,iint),iend(i,iint)
12854             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
12855 !              call dyn_ssbond_ene(i,j,evdwij)
12856 !              evdw=evdw+evdwij
12857 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12858 !                              'evdw',i,j,evdwij,' ss'
12859 !              if (energy_dec) write (iout,*) &
12860 !                              'evdw',i,j,evdwij,' ss'
12861 !             do k=j+1,iend(i,iint)
12862 !C search over all next residues
12863 !              if (dyn_ss_mask(k)) then
12864 !C check if they are cysteins
12865 !C              write(iout,*) 'k=',k
12866
12867 !c              write(iout,*) "PRZED TRI", evdwij
12868 !               evdwij_przed_tri=evdwij
12869 !              call triple_ssbond_ene(i,j,k,evdwij)
12870 !c               if(evdwij_przed_tri.ne.evdwij) then
12871 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
12872 !c               endif
12873
12874 !c              write(iout,*) "PO TRI", evdwij
12875 !C call the energy function that removes the artifical triple disulfide
12876 !C bond the soubroutine is located in ssMD.F
12877 !              evdw=evdw+evdwij
12878               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12879                             'evdw',i,j,evdwij,'tss'
12880 !              endif!dyn_ss_mask(k)
12881 !             enddo! k
12882
12883             ELSE
12884 !el            ind=ind+1
12885             itypj=itype(j,1)
12886             if (itypj.eq.ntyp1) cycle
12887 !            dscj_inv=dsc_inv(itypj)
12888             dscj_inv=vbld_inv(j+nres)
12889 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
12890 !     &       1.0d0/vbld(j+nres)
12891 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
12892             sig0ij=sigma(itypi,itypj)
12893             chi1=chi(itypi,itypj)
12894             chi2=chi(itypj,itypi)
12895             chi12=chi1*chi2
12896             chip1=chip(itypi)
12897             chip2=chip(itypj)
12898             chip12=chip1*chip2
12899             alf1=alp(itypi)
12900             alf2=alp(itypj)
12901             alf12=0.5D0*(alf1+alf2)
12902             xj=c(1,nres+j)
12903             yj=c(2,nres+j)
12904             zj=c(3,nres+j)
12905 ! Searching for nearest neighbour
12906           xj=mod(xj,boxxsize)
12907           if (xj.lt.0) xj=xj+boxxsize
12908           yj=mod(yj,boxysize)
12909           if (yj.lt.0) yj=yj+boxysize
12910           zj=mod(zj,boxzsize)
12911           if (zj.lt.0) zj=zj+boxzsize
12912        if ((zj.gt.bordlipbot)   &
12913       .and.(zj.lt.bordliptop)) then
12914 !C the energy transfer exist
12915         if (zj.lt.buflipbot) then
12916 !C what fraction I am in
12917          fracinbuf=1.0d0-  &
12918              ((zj-bordlipbot)/lipbufthick)
12919 !C lipbufthick is thickenes of lipid buffore
12920          sslipj=sscalelip(fracinbuf)
12921          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
12922         elseif (zj.gt.bufliptop) then
12923          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
12924          sslipj=sscalelip(fracinbuf)
12925          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
12926         else
12927          sslipj=1.0d0
12928          ssgradlipj=0.0
12929         endif
12930        else
12931          sslipj=0.0d0
12932          ssgradlipj=0.0
12933        endif
12934       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12935        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12936       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12937        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12938
12939           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12940           xj_safe=xj
12941           yj_safe=yj
12942           zj_safe=zj
12943           subchap=0
12944           do xshift=-1,1
12945           do yshift=-1,1
12946           do zshift=-1,1
12947           xj=xj_safe+xshift*boxxsize
12948           yj=yj_safe+yshift*boxysize
12949           zj=zj_safe+zshift*boxzsize
12950           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12951           if(dist_temp.lt.dist_init) then
12952             dist_init=dist_temp
12953             xj_temp=xj
12954             yj_temp=yj
12955             zj_temp=zj
12956             subchap=1
12957           endif
12958           enddo
12959           enddo
12960           enddo
12961           if (subchap.eq.1) then
12962           xj=xj_temp-xi
12963           yj=yj_temp-yi
12964           zj=zj_temp-zi
12965           else
12966           xj=xj_safe-xi
12967           yj=yj_safe-yi
12968           zj=zj_safe-zi
12969           endif
12970
12971             dxj=dc_norm(1,nres+j)
12972             dyj=dc_norm(2,nres+j)
12973             dzj=dc_norm(3,nres+j)
12974             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12975             rij=dsqrt(rrij)
12976             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12977             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
12978             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
12979             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
12980             if (sss_ele_cut.le.0.0) cycle
12981             if (sss.lt.1.0d0) then
12982
12983 ! Calculate angle-dependent terms of energy and contributions to their
12984 ! derivatives.
12985               call sc_angular
12986               sigsq=1.0D0/sigsq
12987               sig=sig0ij*dsqrt(sigsq)
12988               rij_shift=1.0D0/rij-sig+sig0ij
12989 ! for diagnostics; uncomment
12990 !              rij_shift=1.2*sig0ij
12991 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12992               if (rij_shift.le.0.0D0) then
12993                 evdw=1.0D20
12994 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
12995 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12996 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
12997                 return
12998               endif
12999               sigder=-sig*sigsq
13000 !---------------------------------------------------------------
13001               rij_shift=1.0D0/rij_shift
13002               fac=rij_shift**expon
13003               e1=fac*fac*aa
13004               e2=fac*bb
13005               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13006               eps2der=evdwij*eps3rt
13007               eps3der=evdwij*eps2rt
13008 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13009 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13010               evdwij=evdwij*eps2rt*eps3rt
13011               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13012               if (lprn) then
13013               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13014               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13015               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13016                 restyp(itypi,1),i,restyp(itypj,1),j,&
13017                 epsi,sigm,chi1,chi2,chip1,chip2,&
13018                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13019                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13020                 evdwij
13021               endif
13022
13023               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13024                               'evdw',i,j,evdwij
13025 !              if (energy_dec) write (iout,*) &
13026 !                              'evdw',i,j,evdwij,"egb_long"
13027
13028 ! Calculate gradient components.
13029               e1=e1*eps1*eps2rt**2*eps3rt**2
13030               fac=-expon*(e1+evdwij)*rij_shift
13031               sigder=fac*sigder
13032               fac=rij*fac
13033               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13034             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13035             /sigmaii(itypi,itypj))
13036 !              fac=0.0d0
13037 ! Calculate the radial part of the gradient
13038               gg(1)=xj*fac
13039               gg(2)=yj*fac
13040               gg(3)=zj*fac
13041 ! Calculate angular part of the gradient.
13042               call sc_grad_scale(1.0d0-sss)
13043             ENDIF    !mask_dyn_ss
13044             endif
13045           enddo      ! j
13046         enddo        ! iint
13047       enddo          ! i
13048 !      write (iout,*) "Number of loop steps in EGB:",ind
13049 !ccc      energy_dec=.false.
13050       return
13051       end subroutine egb_long
13052 !-----------------------------------------------------------------------------
13053       subroutine egb_short(evdw)
13054 !
13055 ! This subroutine calculates the interaction energy of nonbonded side chains
13056 ! assuming the Gay-Berne potential of interaction.
13057 !
13058       use calc_data
13059 !      implicit real*8 (a-h,o-z)
13060 !      include 'DIMENSIONS'
13061 !      include 'COMMON.GEO'
13062 !      include 'COMMON.VAR'
13063 !      include 'COMMON.LOCAL'
13064 !      include 'COMMON.CHAIN'
13065 !      include 'COMMON.DERIV'
13066 !      include 'COMMON.NAMES'
13067 !      include 'COMMON.INTERACT'
13068 !      include 'COMMON.IOUNITS'
13069 !      include 'COMMON.CALC'
13070 !      include 'COMMON.CONTROL'
13071       logical :: lprn
13072 !el local variables
13073       integer :: iint,itypi,itypi1,itypj,subchap
13074       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13075       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13076       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13077                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13078                     ssgradlipi,ssgradlipj
13079       evdw=0.0D0
13080 !cccc      energy_dec=.false.
13081 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13082       evdw=0.0D0
13083       lprn=.false.
13084 !     if (icall.eq.0) lprn=.false.
13085 !el      ind=0
13086       do i=iatsc_s,iatsc_e
13087         itypi=itype(i,1)
13088         if (itypi.eq.ntyp1) cycle
13089         itypi1=itype(i+1,1)
13090         xi=c(1,nres+i)
13091         yi=c(2,nres+i)
13092         zi=c(3,nres+i)
13093           xi=mod(xi,boxxsize)
13094           if (xi.lt.0) xi=xi+boxxsize
13095           yi=mod(yi,boxysize)
13096           if (yi.lt.0) yi=yi+boxysize
13097           zi=mod(zi,boxzsize)
13098           if (zi.lt.0) zi=zi+boxzsize
13099        if ((zi.gt.bordlipbot)    &
13100         .and.(zi.lt.bordliptop)) then
13101 !C the energy transfer exist
13102         if (zi.lt.buflipbot) then
13103 !C what fraction I am in
13104          fracinbuf=1.0d0-    &
13105              ((zi-bordlipbot)/lipbufthick)
13106 !C lipbufthick is thickenes of lipid buffore
13107          sslipi=sscalelip(fracinbuf)
13108          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13109         elseif (zi.gt.bufliptop) then
13110          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13111          sslipi=sscalelip(fracinbuf)
13112          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13113         else
13114          sslipi=1.0d0
13115          ssgradlipi=0.0
13116         endif
13117        else
13118          sslipi=0.0d0
13119          ssgradlipi=0.0
13120        endif
13121
13122         dxi=dc_norm(1,nres+i)
13123         dyi=dc_norm(2,nres+i)
13124         dzi=dc_norm(3,nres+i)
13125 !        dsci_inv=dsc_inv(itypi)
13126         dsci_inv=vbld_inv(i+nres)
13127
13128         dxi=dc_norm(1,nres+i)
13129         dyi=dc_norm(2,nres+i)
13130         dzi=dc_norm(3,nres+i)
13131 !        dsci_inv=dsc_inv(itypi)
13132         dsci_inv=vbld_inv(i+nres)
13133 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13134 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13135 !
13136 ! Calculate SC interaction energy.
13137 !
13138         do iint=1,nint_gr(i)
13139           do j=istart(i,iint),iend(i,iint)
13140             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13141               call dyn_ssbond_ene(i,j,evdwij)
13142               evdw=evdw+evdwij
13143               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13144                               'evdw',i,j,evdwij,' ss'
13145              do k=j+1,iend(i,iint)
13146 !C search over all next residues
13147               if (dyn_ss_mask(k)) then
13148 !C check if they are cysteins
13149 !C              write(iout,*) 'k=',k
13150
13151 !c              write(iout,*) "PRZED TRI", evdwij
13152 !               evdwij_przed_tri=evdwij
13153               call triple_ssbond_ene(i,j,k,evdwij)
13154 !c               if(evdwij_przed_tri.ne.evdwij) then
13155 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13156 !c               endif
13157
13158 !c              write(iout,*) "PO TRI", evdwij
13159 !C call the energy function that removes the artifical triple disulfide
13160 !C bond the soubroutine is located in ssMD.F
13161               evdw=evdw+evdwij
13162               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13163                             'evdw',i,j,evdwij,'tss'
13164               endif!dyn_ss_mask(k)
13165              enddo! k
13166
13167 !              if (energy_dec) write (iout,*) &
13168 !                              'evdw',i,j,evdwij,' ss'
13169             ELSE
13170 !el            ind=ind+1
13171             itypj=itype(j,1)
13172             if (itypj.eq.ntyp1) cycle
13173 !            dscj_inv=dsc_inv(itypj)
13174             dscj_inv=vbld_inv(j+nres)
13175 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13176 !     &       1.0d0/vbld(j+nres)
13177 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13178             sig0ij=sigma(itypi,itypj)
13179             chi1=chi(itypi,itypj)
13180             chi2=chi(itypj,itypi)
13181             chi12=chi1*chi2
13182             chip1=chip(itypi)
13183             chip2=chip(itypj)
13184             chip12=chip1*chip2
13185             alf1=alp(itypi)
13186             alf2=alp(itypj)
13187             alf12=0.5D0*(alf1+alf2)
13188 !            xj=c(1,nres+j)-xi
13189 !            yj=c(2,nres+j)-yi
13190 !            zj=c(3,nres+j)-zi
13191             xj=c(1,nres+j)
13192             yj=c(2,nres+j)
13193             zj=c(3,nres+j)
13194 ! Searching for nearest neighbour
13195           xj=mod(xj,boxxsize)
13196           if (xj.lt.0) xj=xj+boxxsize
13197           yj=mod(yj,boxysize)
13198           if (yj.lt.0) yj=yj+boxysize
13199           zj=mod(zj,boxzsize)
13200           if (zj.lt.0) zj=zj+boxzsize
13201        if ((zj.gt.bordlipbot)   &
13202       .and.(zj.lt.bordliptop)) then
13203 !C the energy transfer exist
13204         if (zj.lt.buflipbot) then
13205 !C what fraction I am in
13206          fracinbuf=1.0d0-  &
13207              ((zj-bordlipbot)/lipbufthick)
13208 !C lipbufthick is thickenes of lipid buffore
13209          sslipj=sscalelip(fracinbuf)
13210          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13211         elseif (zj.gt.bufliptop) then
13212          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13213          sslipj=sscalelip(fracinbuf)
13214          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13215         else
13216          sslipj=1.0d0
13217          ssgradlipj=0.0
13218         endif
13219        else
13220          sslipj=0.0d0
13221          ssgradlipj=0.0
13222        endif
13223       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13224        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13225       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13226        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13227
13228           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13229           xj_safe=xj
13230           yj_safe=yj
13231           zj_safe=zj
13232           subchap=0
13233
13234           do xshift=-1,1
13235           do yshift=-1,1
13236           do zshift=-1,1
13237           xj=xj_safe+xshift*boxxsize
13238           yj=yj_safe+yshift*boxysize
13239           zj=zj_safe+zshift*boxzsize
13240           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13241           if(dist_temp.lt.dist_init) then
13242             dist_init=dist_temp
13243             xj_temp=xj
13244             yj_temp=yj
13245             zj_temp=zj
13246             subchap=1
13247           endif
13248           enddo
13249           enddo
13250           enddo
13251           if (subchap.eq.1) then
13252           xj=xj_temp-xi
13253           yj=yj_temp-yi
13254           zj=zj_temp-zi
13255           else
13256           xj=xj_safe-xi
13257           yj=yj_safe-yi
13258           zj=zj_safe-zi
13259           endif
13260
13261             dxj=dc_norm(1,nres+j)
13262             dyj=dc_norm(2,nres+j)
13263             dzj=dc_norm(3,nres+j)
13264             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13265             rij=dsqrt(rrij)
13266             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13267             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13268             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13269             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13270             if (sss_ele_cut.le.0.0) cycle
13271
13272             if (sss.gt.0.0d0) then
13273
13274 ! Calculate angle-dependent terms of energy and contributions to their
13275 ! derivatives.
13276               call sc_angular
13277               sigsq=1.0D0/sigsq
13278               sig=sig0ij*dsqrt(sigsq)
13279               rij_shift=1.0D0/rij-sig+sig0ij
13280 ! for diagnostics; uncomment
13281 !              rij_shift=1.2*sig0ij
13282 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13283               if (rij_shift.le.0.0D0) then
13284                 evdw=1.0D20
13285 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13286 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13287 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13288                 return
13289               endif
13290               sigder=-sig*sigsq
13291 !---------------------------------------------------------------
13292               rij_shift=1.0D0/rij_shift
13293               fac=rij_shift**expon
13294               e1=fac*fac*aa
13295               e2=fac*bb
13296               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13297               eps2der=evdwij*eps3rt
13298               eps3der=evdwij*eps2rt
13299 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13300 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13301               evdwij=evdwij*eps2rt*eps3rt
13302               evdw=evdw+evdwij*sss*sss_ele_cut
13303               if (lprn) then
13304               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13305               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13306               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13307                 restyp(itypi,1),i,restyp(itypj,1),j,&
13308                 epsi,sigm,chi1,chi2,chip1,chip2,&
13309                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13310                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13311                 evdwij
13312               endif
13313
13314               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13315                               'evdw',i,j,evdwij
13316 !              if (energy_dec) write (iout,*) &
13317 !                              'evdw',i,j,evdwij,"egb_short"
13318
13319 ! Calculate gradient components.
13320               e1=e1*eps1*eps2rt**2*eps3rt**2
13321               fac=-expon*(e1+evdwij)*rij_shift
13322               sigder=fac*sigder
13323               fac=rij*fac
13324               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13325             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13326             /sigmaii(itypi,itypj))
13327
13328 !              fac=0.0d0
13329 ! Calculate the radial part of the gradient
13330               gg(1)=xj*fac
13331               gg(2)=yj*fac
13332               gg(3)=zj*fac
13333 ! Calculate angular part of the gradient.
13334               call sc_grad_scale(sss)
13335             endif
13336           ENDIF !mask_dyn_ss
13337           enddo      ! j
13338         enddo        ! iint
13339       enddo          ! i
13340 !      write (iout,*) "Number of loop steps in EGB:",ind
13341 !ccc      energy_dec=.false.
13342       return
13343       end subroutine egb_short
13344 !-----------------------------------------------------------------------------
13345       subroutine egbv_long(evdw)
13346 !
13347 ! This subroutine calculates the interaction energy of nonbonded side chains
13348 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13349 !
13350       use calc_data
13351 !      implicit real*8 (a-h,o-z)
13352 !      include 'DIMENSIONS'
13353 !      include 'COMMON.GEO'
13354 !      include 'COMMON.VAR'
13355 !      include 'COMMON.LOCAL'
13356 !      include 'COMMON.CHAIN'
13357 !      include 'COMMON.DERIV'
13358 !      include 'COMMON.NAMES'
13359 !      include 'COMMON.INTERACT'
13360 !      include 'COMMON.IOUNITS'
13361 !      include 'COMMON.CALC'
13362       use comm_srutu
13363 !el      integer :: icall
13364 !el      common /srutu/ icall
13365       logical :: lprn
13366 !el local variables
13367       integer :: iint,itypi,itypi1,itypj
13368       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13369       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13370       evdw=0.0D0
13371 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13372       evdw=0.0D0
13373       lprn=.false.
13374 !     if (icall.eq.0) lprn=.true.
13375 !el      ind=0
13376       do i=iatsc_s,iatsc_e
13377         itypi=itype(i,1)
13378         if (itypi.eq.ntyp1) cycle
13379         itypi1=itype(i+1,1)
13380         xi=c(1,nres+i)
13381         yi=c(2,nres+i)
13382         zi=c(3,nres+i)
13383         dxi=dc_norm(1,nres+i)
13384         dyi=dc_norm(2,nres+i)
13385         dzi=dc_norm(3,nres+i)
13386 !        dsci_inv=dsc_inv(itypi)
13387         dsci_inv=vbld_inv(i+nres)
13388 !
13389 ! Calculate SC interaction energy.
13390 !
13391         do iint=1,nint_gr(i)
13392           do j=istart(i,iint),iend(i,iint)
13393 !el            ind=ind+1
13394             itypj=itype(j,1)
13395             if (itypj.eq.ntyp1) cycle
13396 !            dscj_inv=dsc_inv(itypj)
13397             dscj_inv=vbld_inv(j+nres)
13398             sig0ij=sigma(itypi,itypj)
13399             r0ij=r0(itypi,itypj)
13400             chi1=chi(itypi,itypj)
13401             chi2=chi(itypj,itypi)
13402             chi12=chi1*chi2
13403             chip1=chip(itypi)
13404             chip2=chip(itypj)
13405             chip12=chip1*chip2
13406             alf1=alp(itypi)
13407             alf2=alp(itypj)
13408             alf12=0.5D0*(alf1+alf2)
13409             xj=c(1,nres+j)-xi
13410             yj=c(2,nres+j)-yi
13411             zj=c(3,nres+j)-zi
13412             dxj=dc_norm(1,nres+j)
13413             dyj=dc_norm(2,nres+j)
13414             dzj=dc_norm(3,nres+j)
13415             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13416             rij=dsqrt(rrij)
13417
13418             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13419
13420             if (sss.lt.1.0d0) then
13421
13422 ! Calculate angle-dependent terms of energy and contributions to their
13423 ! derivatives.
13424               call sc_angular
13425               sigsq=1.0D0/sigsq
13426               sig=sig0ij*dsqrt(sigsq)
13427               rij_shift=1.0D0/rij-sig+r0ij
13428 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13429               if (rij_shift.le.0.0D0) then
13430                 evdw=1.0D20
13431                 return
13432               endif
13433               sigder=-sig*sigsq
13434 !---------------------------------------------------------------
13435               rij_shift=1.0D0/rij_shift
13436               fac=rij_shift**expon
13437               e1=fac*fac*aa_aq(itypi,itypj)
13438               e2=fac*bb_aq(itypi,itypj)
13439               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13440               eps2der=evdwij*eps3rt
13441               eps3der=evdwij*eps2rt
13442               fac_augm=rrij**expon
13443               e_augm=augm(itypi,itypj)*fac_augm
13444               evdwij=evdwij*eps2rt*eps3rt
13445               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13446               if (lprn) then
13447               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13448               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13449               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13450                 restyp(itypi,1),i,restyp(itypj,1),j,&
13451                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13452                 chi1,chi2,chip1,chip2,&
13453                 eps1,eps2rt**2,eps3rt**2,&
13454                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13455                 evdwij+e_augm
13456               endif
13457 ! Calculate gradient components.
13458               e1=e1*eps1*eps2rt**2*eps3rt**2
13459               fac=-expon*(e1+evdwij)*rij_shift
13460               sigder=fac*sigder
13461               fac=rij*fac-2*expon*rrij*e_augm
13462 ! Calculate the radial part of the gradient
13463               gg(1)=xj*fac
13464               gg(2)=yj*fac
13465               gg(3)=zj*fac
13466 ! Calculate angular part of the gradient.
13467               call sc_grad_scale(1.0d0-sss)
13468             endif
13469           enddo      ! j
13470         enddo        ! iint
13471       enddo          ! i
13472       end subroutine egbv_long
13473 !-----------------------------------------------------------------------------
13474       subroutine egbv_short(evdw)
13475 !
13476 ! This subroutine calculates the interaction energy of nonbonded side chains
13477 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13478 !
13479       use calc_data
13480 !      implicit real*8 (a-h,o-z)
13481 !      include 'DIMENSIONS'
13482 !      include 'COMMON.GEO'
13483 !      include 'COMMON.VAR'
13484 !      include 'COMMON.LOCAL'
13485 !      include 'COMMON.CHAIN'
13486 !      include 'COMMON.DERIV'
13487 !      include 'COMMON.NAMES'
13488 !      include 'COMMON.INTERACT'
13489 !      include 'COMMON.IOUNITS'
13490 !      include 'COMMON.CALC'
13491       use comm_srutu
13492 !el      integer :: icall
13493 !el      common /srutu/ icall
13494       logical :: lprn
13495 !el local variables
13496       integer :: iint,itypi,itypi1,itypj
13497       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13498       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13499       evdw=0.0D0
13500 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13501       evdw=0.0D0
13502       lprn=.false.
13503 !     if (icall.eq.0) lprn=.true.
13504 !el      ind=0
13505       do i=iatsc_s,iatsc_e
13506         itypi=itype(i,1)
13507         if (itypi.eq.ntyp1) cycle
13508         itypi1=itype(i+1,1)
13509         xi=c(1,nres+i)
13510         yi=c(2,nres+i)
13511         zi=c(3,nres+i)
13512         dxi=dc_norm(1,nres+i)
13513         dyi=dc_norm(2,nres+i)
13514         dzi=dc_norm(3,nres+i)
13515 !        dsci_inv=dsc_inv(itypi)
13516         dsci_inv=vbld_inv(i+nres)
13517 !
13518 ! Calculate SC interaction energy.
13519 !
13520         do iint=1,nint_gr(i)
13521           do j=istart(i,iint),iend(i,iint)
13522 !el            ind=ind+1
13523             itypj=itype(j,1)
13524             if (itypj.eq.ntyp1) cycle
13525 !            dscj_inv=dsc_inv(itypj)
13526             dscj_inv=vbld_inv(j+nres)
13527             sig0ij=sigma(itypi,itypj)
13528             r0ij=r0(itypi,itypj)
13529             chi1=chi(itypi,itypj)
13530             chi2=chi(itypj,itypi)
13531             chi12=chi1*chi2
13532             chip1=chip(itypi)
13533             chip2=chip(itypj)
13534             chip12=chip1*chip2
13535             alf1=alp(itypi)
13536             alf2=alp(itypj)
13537             alf12=0.5D0*(alf1+alf2)
13538             xj=c(1,nres+j)-xi
13539             yj=c(2,nres+j)-yi
13540             zj=c(3,nres+j)-zi
13541             dxj=dc_norm(1,nres+j)
13542             dyj=dc_norm(2,nres+j)
13543             dzj=dc_norm(3,nres+j)
13544             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13545             rij=dsqrt(rrij)
13546
13547             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13548
13549             if (sss.gt.0.0d0) then
13550
13551 ! Calculate angle-dependent terms of energy and contributions to their
13552 ! derivatives.
13553               call sc_angular
13554               sigsq=1.0D0/sigsq
13555               sig=sig0ij*dsqrt(sigsq)
13556               rij_shift=1.0D0/rij-sig+r0ij
13557 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13558               if (rij_shift.le.0.0D0) then
13559                 evdw=1.0D20
13560                 return
13561               endif
13562               sigder=-sig*sigsq
13563 !---------------------------------------------------------------
13564               rij_shift=1.0D0/rij_shift
13565               fac=rij_shift**expon
13566               e1=fac*fac*aa_aq(itypi,itypj)
13567               e2=fac*bb_aq(itypi,itypj)
13568               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13569               eps2der=evdwij*eps3rt
13570               eps3der=evdwij*eps2rt
13571               fac_augm=rrij**expon
13572               e_augm=augm(itypi,itypj)*fac_augm
13573               evdwij=evdwij*eps2rt*eps3rt
13574               evdw=evdw+(evdwij+e_augm)*sss
13575               if (lprn) then
13576               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13577               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13578               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13579                 restyp(itypi,1),i,restyp(itypj,1),j,&
13580                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13581                 chi1,chi2,chip1,chip2,&
13582                 eps1,eps2rt**2,eps3rt**2,&
13583                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13584                 evdwij+e_augm
13585               endif
13586 ! Calculate gradient components.
13587               e1=e1*eps1*eps2rt**2*eps3rt**2
13588               fac=-expon*(e1+evdwij)*rij_shift
13589               sigder=fac*sigder
13590               fac=rij*fac-2*expon*rrij*e_augm
13591 ! Calculate the radial part of the gradient
13592               gg(1)=xj*fac
13593               gg(2)=yj*fac
13594               gg(3)=zj*fac
13595 ! Calculate angular part of the gradient.
13596               call sc_grad_scale(sss)
13597             endif
13598           enddo      ! j
13599         enddo        ! iint
13600       enddo          ! i
13601       end subroutine egbv_short
13602 !-----------------------------------------------------------------------------
13603       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13604 !
13605 ! This subroutine calculates the average interaction energy and its gradient
13606 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13607 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13608 ! The potential depends both on the distance of peptide-group centers and on
13609 ! the orientation of the CA-CA virtual bonds.
13610 !
13611 !      implicit real*8 (a-h,o-z)
13612
13613       use comm_locel
13614 #ifdef MPI
13615       include 'mpif.h'
13616 #endif
13617 !      include 'DIMENSIONS'
13618 !      include 'COMMON.CONTROL'
13619 !      include 'COMMON.SETUP'
13620 !      include 'COMMON.IOUNITS'
13621 !      include 'COMMON.GEO'
13622 !      include 'COMMON.VAR'
13623 !      include 'COMMON.LOCAL'
13624 !      include 'COMMON.CHAIN'
13625 !      include 'COMMON.DERIV'
13626 !      include 'COMMON.INTERACT'
13627 !      include 'COMMON.CONTACTS'
13628 !      include 'COMMON.TORSION'
13629 !      include 'COMMON.VECTORS'
13630 !      include 'COMMON.FFIELD'
13631 !      include 'COMMON.TIME1'
13632       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13633       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13634       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13635 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13636       real(kind=8),dimension(4) :: muij
13637 !el      integer :: num_conti,j1,j2
13638 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13639 !el                   dz_normi,xmedi,ymedi,zmedi
13640 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13641 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13642 !el          num_conti,j1,j2
13643 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13644 #ifdef MOMENT
13645       real(kind=8) :: scal_el=1.0d0
13646 #else
13647       real(kind=8) :: scal_el=0.5d0
13648 #endif
13649 ! 12/13/98
13650 ! 13-go grudnia roku pamietnego...
13651       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13652                                              0.0d0,1.0d0,0.0d0,&
13653                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13654 !el local variables
13655       integer :: i,j,k
13656       real(kind=8) :: fac
13657       real(kind=8) :: dxj,dyj,dzj
13658       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13659
13660 !      allocate(num_cont_hb(nres)) !(maxres)
13661 !d      write(iout,*) 'In EELEC'
13662 !d      do i=1,nloctyp
13663 !d        write(iout,*) 'Type',i
13664 !d        write(iout,*) 'B1',B1(:,i)
13665 !d        write(iout,*) 'B2',B2(:,i)
13666 !d        write(iout,*) 'CC',CC(:,:,i)
13667 !d        write(iout,*) 'DD',DD(:,:,i)
13668 !d        write(iout,*) 'EE',EE(:,:,i)
13669 !d      enddo
13670 !d      call check_vecgrad
13671 !d      stop
13672       if (icheckgrad.eq.1) then
13673         do i=1,nres-1
13674           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13675           do k=1,3
13676             dc_norm(k,i)=dc(k,i)*fac
13677           enddo
13678 !          write (iout,*) 'i',i,' fac',fac
13679         enddo
13680       endif
13681       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13682           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13683           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13684 !        call vec_and_deriv
13685 #ifdef TIMING
13686         time01=MPI_Wtime()
13687 #endif
13688 !        print *, "before set matrices"
13689         call set_matrices
13690 !        print *,"after set martices"
13691 #ifdef TIMING
13692         time_mat=time_mat+MPI_Wtime()-time01
13693 #endif
13694       endif
13695 !d      do i=1,nres-1
13696 !d        write (iout,*) 'i=',i
13697 !d        do k=1,3
13698 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
13699 !d        enddo
13700 !d        do k=1,3
13701 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
13702 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
13703 !d        enddo
13704 !d      enddo
13705       t_eelecij=0.0d0
13706       ees=0.0D0
13707       evdw1=0.0D0
13708       eel_loc=0.0d0
13709       eello_turn3=0.0d0
13710       eello_turn4=0.0d0
13711 !el      ind=0
13712       do i=1,nres
13713         num_cont_hb(i)=0
13714       enddo
13715 !d      print '(a)','Enter EELEC'
13716 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
13717 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13718 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13719       do i=1,nres
13720         gel_loc_loc(i)=0.0d0
13721         gcorr_loc(i)=0.0d0
13722       enddo
13723 !
13724 !
13725 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
13726 !
13727 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
13728 !
13729       do i=iturn3_start,iturn3_end
13730         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
13731         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
13732         dxi=dc(1,i)
13733         dyi=dc(2,i)
13734         dzi=dc(3,i)
13735         dx_normi=dc_norm(1,i)
13736         dy_normi=dc_norm(2,i)
13737         dz_normi=dc_norm(3,i)
13738         xmedi=c(1,i)+0.5d0*dxi
13739         ymedi=c(2,i)+0.5d0*dyi
13740         zmedi=c(3,i)+0.5d0*dzi
13741           xmedi=dmod(xmedi,boxxsize)
13742           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13743           ymedi=dmod(ymedi,boxysize)
13744           if (ymedi.lt.0) ymedi=ymedi+boxysize
13745           zmedi=dmod(zmedi,boxzsize)
13746           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13747         num_conti=0
13748         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
13749         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
13750         num_cont_hb(i)=num_conti
13751       enddo
13752       do i=iturn4_start,iturn4_end
13753         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
13754           .or. itype(i+3,1).eq.ntyp1 &
13755           .or. itype(i+4,1).eq.ntyp1) cycle
13756         dxi=dc(1,i)
13757         dyi=dc(2,i)
13758         dzi=dc(3,i)
13759         dx_normi=dc_norm(1,i)
13760         dy_normi=dc_norm(2,i)
13761         dz_normi=dc_norm(3,i)
13762         xmedi=c(1,i)+0.5d0*dxi
13763         ymedi=c(2,i)+0.5d0*dyi
13764         zmedi=c(3,i)+0.5d0*dzi
13765           xmedi=dmod(xmedi,boxxsize)
13766           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13767           ymedi=dmod(ymedi,boxysize)
13768           if (ymedi.lt.0) ymedi=ymedi+boxysize
13769           zmedi=dmod(zmedi,boxzsize)
13770           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13771         num_conti=num_cont_hb(i)
13772         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
13773         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
13774           call eturn4(i,eello_turn4)
13775         num_cont_hb(i)=num_conti
13776       enddo   ! i
13777 !
13778 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
13779 !
13780       do i=iatel_s,iatel_e
13781         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
13782         dxi=dc(1,i)
13783         dyi=dc(2,i)
13784         dzi=dc(3,i)
13785         dx_normi=dc_norm(1,i)
13786         dy_normi=dc_norm(2,i)
13787         dz_normi=dc_norm(3,i)
13788         xmedi=c(1,i)+0.5d0*dxi
13789         ymedi=c(2,i)+0.5d0*dyi
13790         zmedi=c(3,i)+0.5d0*dzi
13791           xmedi=dmod(xmedi,boxxsize)
13792           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13793           ymedi=dmod(ymedi,boxysize)
13794           if (ymedi.lt.0) ymedi=ymedi+boxysize
13795           zmedi=dmod(zmedi,boxzsize)
13796           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13797 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
13798         num_conti=num_cont_hb(i)
13799         do j=ielstart(i),ielend(i)
13800           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
13801           call eelecij_scale(i,j,ees,evdw1,eel_loc)
13802         enddo ! j
13803         num_cont_hb(i)=num_conti
13804       enddo   ! i
13805 !      write (iout,*) "Number of loop steps in EELEC:",ind
13806 !d      do i=1,nres
13807 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
13808 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
13809 !d      enddo
13810 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
13811 !cc      eel_loc=eel_loc+eello_turn3
13812 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
13813       return
13814       end subroutine eelec_scale
13815 !-----------------------------------------------------------------------------
13816       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
13817 !      implicit real*8 (a-h,o-z)
13818
13819       use comm_locel
13820 !      include 'DIMENSIONS'
13821 #ifdef MPI
13822       include "mpif.h"
13823 #endif
13824 !      include 'COMMON.CONTROL'
13825 !      include 'COMMON.IOUNITS'
13826 !      include 'COMMON.GEO'
13827 !      include 'COMMON.VAR'
13828 !      include 'COMMON.LOCAL'
13829 !      include 'COMMON.CHAIN'
13830 !      include 'COMMON.DERIV'
13831 !      include 'COMMON.INTERACT'
13832 !      include 'COMMON.CONTACTS'
13833 !      include 'COMMON.TORSION'
13834 !      include 'COMMON.VECTORS'
13835 !      include 'COMMON.FFIELD'
13836 !      include 'COMMON.TIME1'
13837       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
13838       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
13839       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13840 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13841       real(kind=8),dimension(4) :: muij
13842       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13843                     dist_temp, dist_init,sss_grad
13844       integer xshift,yshift,zshift
13845
13846 !el      integer :: num_conti,j1,j2
13847 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13848 !el                   dz_normi,xmedi,ymedi,zmedi
13849 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13850 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13851 !el          num_conti,j1,j2
13852 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13853 #ifdef MOMENT
13854       real(kind=8) :: scal_el=1.0d0
13855 #else
13856       real(kind=8) :: scal_el=0.5d0
13857 #endif
13858 ! 12/13/98
13859 ! 13-go grudnia roku pamietnego...
13860       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13861                                              0.0d0,1.0d0,0.0d0,&
13862                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13863 !el local variables
13864       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
13865       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
13866       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
13867       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
13868       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
13869       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
13870       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
13871                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
13872                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
13873                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
13874                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
13875                   ecosam,ecosbm,ecosgm,ghalf,time00
13876 !      integer :: maxconts
13877 !      maxconts = nres/4
13878 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13879 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13880 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13881 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13882 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13883 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13884 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13885 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13886 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
13887 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
13888 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
13889 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
13890 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
13891
13892 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
13893 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
13894
13895 #ifdef MPI
13896           time00=MPI_Wtime()
13897 #endif
13898 !d      write (iout,*) "eelecij",i,j
13899 !el          ind=ind+1
13900           iteli=itel(i)
13901           itelj=itel(j)
13902           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
13903           aaa=app(iteli,itelj)
13904           bbb=bpp(iteli,itelj)
13905           ael6i=ael6(iteli,itelj)
13906           ael3i=ael3(iteli,itelj)
13907           dxj=dc(1,j)
13908           dyj=dc(2,j)
13909           dzj=dc(3,j)
13910           dx_normj=dc_norm(1,j)
13911           dy_normj=dc_norm(2,j)
13912           dz_normj=dc_norm(3,j)
13913 !          xj=c(1,j)+0.5D0*dxj-xmedi
13914 !          yj=c(2,j)+0.5D0*dyj-ymedi
13915 !          zj=c(3,j)+0.5D0*dzj-zmedi
13916           xj=c(1,j)+0.5D0*dxj
13917           yj=c(2,j)+0.5D0*dyj
13918           zj=c(3,j)+0.5D0*dzj
13919           xj=mod(xj,boxxsize)
13920           if (xj.lt.0) xj=xj+boxxsize
13921           yj=mod(yj,boxysize)
13922           if (yj.lt.0) yj=yj+boxysize
13923           zj=mod(zj,boxzsize)
13924           if (zj.lt.0) zj=zj+boxzsize
13925       isubchap=0
13926       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13927       xj_safe=xj
13928       yj_safe=yj
13929       zj_safe=zj
13930       do xshift=-1,1
13931       do yshift=-1,1
13932       do zshift=-1,1
13933           xj=xj_safe+xshift*boxxsize
13934           yj=yj_safe+yshift*boxysize
13935           zj=zj_safe+zshift*boxzsize
13936           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13937           if(dist_temp.lt.dist_init) then
13938             dist_init=dist_temp
13939             xj_temp=xj
13940             yj_temp=yj
13941             zj_temp=zj
13942             isubchap=1
13943           endif
13944        enddo
13945        enddo
13946        enddo
13947        if (isubchap.eq.1) then
13948 !C          print *,i,j
13949           xj=xj_temp-xmedi
13950           yj=yj_temp-ymedi
13951           zj=zj_temp-zmedi
13952        else
13953           xj=xj_safe-xmedi
13954           yj=yj_safe-ymedi
13955           zj=zj_safe-zmedi
13956        endif
13957
13958           rij=xj*xj+yj*yj+zj*zj
13959           rrmij=1.0D0/rij
13960           rij=dsqrt(rij)
13961           rmij=1.0D0/rij
13962 ! For extracting the short-range part of Evdwpp
13963           sss=sscale(rij/rpp(iteli,itelj))
13964             sss_ele_cut=sscale_ele(rij)
13965             sss_ele_grad=sscagrad_ele(rij)
13966             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
13967 !             sss_ele_cut=1.0d0
13968 !             sss_ele_grad=0.0d0
13969             if (sss_ele_cut.le.0.0) go to 128
13970
13971           r3ij=rrmij*rmij
13972           r6ij=r3ij*r3ij
13973           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
13974           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
13975           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
13976           fac=cosa-3.0D0*cosb*cosg
13977           ev1=aaa*r6ij*r6ij
13978 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
13979           if (j.eq.i+2) ev1=scal_el*ev1
13980           ev2=bbb*r6ij
13981           fac3=ael6i*r6ij
13982           fac4=ael3i*r3ij
13983           evdwij=ev1+ev2
13984           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
13985           el2=fac4*fac
13986           eesij=el1+el2
13987 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
13988           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
13989           ees=ees+eesij*sss_ele_cut
13990           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
13991 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
13992 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
13993 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
13994 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
13995
13996           if (energy_dec) then
13997               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
13998               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
13999           endif
14000
14001 !
14002 ! Calculate contributions to the Cartesian gradient.
14003 !
14004 #ifdef SPLITELE
14005           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14006           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14007           fac1=fac
14008           erij(1)=xj*rmij
14009           erij(2)=yj*rmij
14010           erij(3)=zj*rmij
14011 !
14012 ! Radial derivatives. First process both termini of the fragment (i,j)
14013 !
14014           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14015           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14016           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14017 !          do k=1,3
14018 !            ghalf=0.5D0*ggg(k)
14019 !            gelc(k,i)=gelc(k,i)+ghalf
14020 !            gelc(k,j)=gelc(k,j)+ghalf
14021 !          enddo
14022 ! 9/28/08 AL Gradient compotents will be summed only at the end
14023           do k=1,3
14024             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14025             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14026           enddo
14027 !
14028 ! Loop over residues i+1 thru j-1.
14029 !
14030 !grad          do k=i+1,j-1
14031 !grad            do l=1,3
14032 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14033 !grad            enddo
14034 !grad          enddo
14035           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14036           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14037           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14038           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14039           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14040           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14041 !          do k=1,3
14042 !            ghalf=0.5D0*ggg(k)
14043 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14044 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14045 !          enddo
14046 ! 9/28/08 AL Gradient compotents will be summed only at the end
14047           do k=1,3
14048             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14049             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14050           enddo
14051 !
14052 ! Loop over residues i+1 thru j-1.
14053 !
14054 !grad          do k=i+1,j-1
14055 !grad            do l=1,3
14056 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14057 !grad            enddo
14058 !grad          enddo
14059 #else
14060           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14061           facel=(el1+eesij)*sss_ele_cut
14062           fac1=fac
14063           fac=-3*rrmij*(facvdw+facvdw+facel)
14064           erij(1)=xj*rmij
14065           erij(2)=yj*rmij
14066           erij(3)=zj*rmij
14067 !
14068 ! Radial derivatives. First process both termini of the fragment (i,j)
14069 !
14070           ggg(1)=fac*xj
14071           ggg(2)=fac*yj
14072           ggg(3)=fac*zj
14073 !          do k=1,3
14074 !            ghalf=0.5D0*ggg(k)
14075 !            gelc(k,i)=gelc(k,i)+ghalf
14076 !            gelc(k,j)=gelc(k,j)+ghalf
14077 !          enddo
14078 ! 9/28/08 AL Gradient compotents will be summed only at the end
14079           do k=1,3
14080             gelc_long(k,j)=gelc(k,j)+ggg(k)
14081             gelc_long(k,i)=gelc(k,i)-ggg(k)
14082           enddo
14083 !
14084 ! Loop over residues i+1 thru j-1.
14085 !
14086 !grad          do k=i+1,j-1
14087 !grad            do l=1,3
14088 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14089 !grad            enddo
14090 !grad          enddo
14091 ! 9/28/08 AL Gradient compotents will be summed only at the end
14092           ggg(1)=facvdw*xj
14093           ggg(2)=facvdw*yj
14094           ggg(3)=facvdw*zj
14095           do k=1,3
14096             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14097             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14098           enddo
14099 #endif
14100 !
14101 ! Angular part
14102 !
14103           ecosa=2.0D0*fac3*fac1+fac4
14104           fac4=-3.0D0*fac4
14105           fac3=-6.0D0*fac3
14106           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14107           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14108           do k=1,3
14109             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14110             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14111           enddo
14112 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14113 !d   &          (dcosg(k),k=1,3)
14114           do k=1,3
14115             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14116           enddo
14117 !          do k=1,3
14118 !            ghalf=0.5D0*ggg(k)
14119 !            gelc(k,i)=gelc(k,i)+ghalf
14120 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14121 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14122 !            gelc(k,j)=gelc(k,j)+ghalf
14123 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14124 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14125 !          enddo
14126 !grad          do k=i+1,j-1
14127 !grad            do l=1,3
14128 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14129 !grad            enddo
14130 !grad          enddo
14131           do k=1,3
14132             gelc(k,i)=gelc(k,i) &
14133                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14134                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14135                      *sss_ele_cut
14136             gelc(k,j)=gelc(k,j) &
14137                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14138                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14139                      *sss_ele_cut
14140             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14141             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14142           enddo
14143           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14144               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14145               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14146 !
14147 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14148 !   energy of a peptide unit is assumed in the form of a second-order
14149 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14150 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14151 !   are computed for EVERY pair of non-contiguous peptide groups.
14152 !
14153           if (j.lt.nres-1) then
14154             j1=j+1
14155             j2=j-1
14156           else
14157             j1=j-1
14158             j2=j-2
14159           endif
14160           kkk=0
14161           do k=1,2
14162             do l=1,2
14163               kkk=kkk+1
14164               muij(kkk)=mu(k,i)*mu(l,j)
14165             enddo
14166           enddo
14167 !d         write (iout,*) 'EELEC: i',i,' j',j
14168 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14169 !d          write(iout,*) 'muij',muij
14170           ury=scalar(uy(1,i),erij)
14171           urz=scalar(uz(1,i),erij)
14172           vry=scalar(uy(1,j),erij)
14173           vrz=scalar(uz(1,j),erij)
14174           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14175           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14176           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14177           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14178           fac=dsqrt(-ael6i)*r3ij
14179           a22=a22*fac
14180           a23=a23*fac
14181           a32=a32*fac
14182           a33=a33*fac
14183 !d          write (iout,'(4i5,4f10.5)')
14184 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14185 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14186 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14187 !d     &      uy(:,j),uz(:,j)
14188 !d          write (iout,'(4f10.5)')
14189 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14190 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14191 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14192 !d           write (iout,'(9f10.5/)')
14193 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14194 ! Derivatives of the elements of A in virtual-bond vectors
14195           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14196           do k=1,3
14197             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14198             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14199             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14200             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14201             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14202             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14203             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14204             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14205             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14206             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14207             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14208             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14209           enddo
14210 ! Compute radial contributions to the gradient
14211           facr=-3.0d0*rrmij
14212           a22der=a22*facr
14213           a23der=a23*facr
14214           a32der=a32*facr
14215           a33der=a33*facr
14216           agg(1,1)=a22der*xj
14217           agg(2,1)=a22der*yj
14218           agg(3,1)=a22der*zj
14219           agg(1,2)=a23der*xj
14220           agg(2,2)=a23der*yj
14221           agg(3,2)=a23der*zj
14222           agg(1,3)=a32der*xj
14223           agg(2,3)=a32der*yj
14224           agg(3,3)=a32der*zj
14225           agg(1,4)=a33der*xj
14226           agg(2,4)=a33der*yj
14227           agg(3,4)=a33der*zj
14228 ! Add the contributions coming from er
14229           fac3=-3.0d0*fac
14230           do k=1,3
14231             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14232             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14233             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14234             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14235           enddo
14236           do k=1,3
14237 ! Derivatives in DC(i)
14238 !grad            ghalf1=0.5d0*agg(k,1)
14239 !grad            ghalf2=0.5d0*agg(k,2)
14240 !grad            ghalf3=0.5d0*agg(k,3)
14241 !grad            ghalf4=0.5d0*agg(k,4)
14242             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14243             -3.0d0*uryg(k,2)*vry)!+ghalf1
14244             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14245             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14246             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14247             -3.0d0*urzg(k,2)*vry)!+ghalf3
14248             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14249             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14250 ! Derivatives in DC(i+1)
14251             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14252             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14253             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14254             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14255             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14256             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14257             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14258             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14259 ! Derivatives in DC(j)
14260             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14261             -3.0d0*vryg(k,2)*ury)!+ghalf1
14262             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14263             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14264             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14265             -3.0d0*vryg(k,2)*urz)!+ghalf3
14266             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14267             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14268 ! Derivatives in DC(j+1) or DC(nres-1)
14269             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14270             -3.0d0*vryg(k,3)*ury)
14271             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14272             -3.0d0*vrzg(k,3)*ury)
14273             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14274             -3.0d0*vryg(k,3)*urz)
14275             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14276             -3.0d0*vrzg(k,3)*urz)
14277 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14278 !grad              do l=1,4
14279 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14280 !grad              enddo
14281 !grad            endif
14282           enddo
14283           acipa(1,1)=a22
14284           acipa(1,2)=a23
14285           acipa(2,1)=a32
14286           acipa(2,2)=a33
14287           a22=-a22
14288           a23=-a23
14289           do l=1,2
14290             do k=1,3
14291               agg(k,l)=-agg(k,l)
14292               aggi(k,l)=-aggi(k,l)
14293               aggi1(k,l)=-aggi1(k,l)
14294               aggj(k,l)=-aggj(k,l)
14295               aggj1(k,l)=-aggj1(k,l)
14296             enddo
14297           enddo
14298           if (j.lt.nres-1) then
14299             a22=-a22
14300             a32=-a32
14301             do l=1,3,2
14302               do k=1,3
14303                 agg(k,l)=-agg(k,l)
14304                 aggi(k,l)=-aggi(k,l)
14305                 aggi1(k,l)=-aggi1(k,l)
14306                 aggj(k,l)=-aggj(k,l)
14307                 aggj1(k,l)=-aggj1(k,l)
14308               enddo
14309             enddo
14310           else
14311             a22=-a22
14312             a23=-a23
14313             a32=-a32
14314             a33=-a33
14315             do l=1,4
14316               do k=1,3
14317                 agg(k,l)=-agg(k,l)
14318                 aggi(k,l)=-aggi(k,l)
14319                 aggi1(k,l)=-aggi1(k,l)
14320                 aggj(k,l)=-aggj(k,l)
14321                 aggj1(k,l)=-aggj1(k,l)
14322               enddo
14323             enddo
14324           endif
14325           ENDIF ! WCORR
14326           IF (wel_loc.gt.0.0d0) THEN
14327 ! Contribution to the local-electrostatic energy coming from the i-j pair
14328           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14329            +a33*muij(4)
14330 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14331
14332           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14333                   'eelloc',i,j,eel_loc_ij
14334 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14335
14336           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14337 ! Partial derivatives in virtual-bond dihedral angles gamma
14338           if (i.gt.1) &
14339           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14340                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14341                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14342                  *sss_ele_cut
14343           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14344                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14345                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14346                  *sss_ele_cut
14347            xtemp(1)=xj
14348            xtemp(2)=yj
14349            xtemp(3)=zj
14350
14351 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14352           do l=1,3
14353             ggg(l)=(agg(l,1)*muij(1)+ &
14354                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14355             *sss_ele_cut &
14356              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14357
14358             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14359             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14360 !grad            ghalf=0.5d0*ggg(l)
14361 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14362 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14363           enddo
14364 !grad          do k=i+1,j2
14365 !grad            do l=1,3
14366 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14367 !grad            enddo
14368 !grad          enddo
14369 ! Remaining derivatives of eello
14370           do l=1,3
14371             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14372                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14373             *sss_ele_cut
14374
14375             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14376                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14377             *sss_ele_cut
14378
14379             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14380                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14381             *sss_ele_cut
14382
14383             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14384                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14385             *sss_ele_cut
14386
14387           enddo
14388           ENDIF
14389 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14390 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14391           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14392              .and. num_conti.le.maxconts) then
14393 !            write (iout,*) i,j," entered corr"
14394 !
14395 ! Calculate the contact function. The ith column of the array JCONT will
14396 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14397 ! greater than I). The arrays FACONT and GACONT will contain the values of
14398 ! the contact function and its derivative.
14399 !           r0ij=1.02D0*rpp(iteli,itelj)
14400 !           r0ij=1.11D0*rpp(iteli,itelj)
14401             r0ij=2.20D0*rpp(iteli,itelj)
14402 !           r0ij=1.55D0*rpp(iteli,itelj)
14403             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14404 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14405             if (fcont.gt.0.0D0) then
14406               num_conti=num_conti+1
14407               if (num_conti.gt.maxconts) then
14408 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14409                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14410                                ' will skip next contacts for this conf.',num_conti
14411               else
14412                 jcont_hb(num_conti,i)=j
14413 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14414 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14415                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14416                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14417 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14418 !  terms.
14419                 d_cont(num_conti,i)=rij
14420 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14421 !     --- Electrostatic-interaction matrix ---
14422                 a_chuj(1,1,num_conti,i)=a22
14423                 a_chuj(1,2,num_conti,i)=a23
14424                 a_chuj(2,1,num_conti,i)=a32
14425                 a_chuj(2,2,num_conti,i)=a33
14426 !     --- Gradient of rij
14427                 do kkk=1,3
14428                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14429                 enddo
14430                 kkll=0
14431                 do k=1,2
14432                   do l=1,2
14433                     kkll=kkll+1
14434                     do m=1,3
14435                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14436                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14437                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14438                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14439                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14440                     enddo
14441                   enddo
14442                 enddo
14443                 ENDIF
14444                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14445 ! Calculate contact energies
14446                 cosa4=4.0D0*cosa
14447                 wij=cosa-3.0D0*cosb*cosg
14448                 cosbg1=cosb+cosg
14449                 cosbg2=cosb-cosg
14450 !               fac3=dsqrt(-ael6i)/r0ij**3
14451                 fac3=dsqrt(-ael6i)*r3ij
14452 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14453                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14454                 if (ees0tmp.gt.0) then
14455                   ees0pij=dsqrt(ees0tmp)
14456                 else
14457                   ees0pij=0
14458                 endif
14459 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14460                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14461                 if (ees0tmp.gt.0) then
14462                   ees0mij=dsqrt(ees0tmp)
14463                 else
14464                   ees0mij=0
14465                 endif
14466 !               ees0mij=0.0D0
14467                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14468                      *sss_ele_cut
14469
14470                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14471                      *sss_ele_cut
14472
14473 ! Diagnostics. Comment out or remove after debugging!
14474 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14475 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14476 !               ees0m(num_conti,i)=0.0D0
14477 ! End diagnostics.
14478 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14479 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14480 ! Angular derivatives of the contact function
14481                 ees0pij1=fac3/ees0pij
14482                 ees0mij1=fac3/ees0mij
14483                 fac3p=-3.0D0*fac3*rrmij
14484                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14485                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14486 !               ees0mij1=0.0D0
14487                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14488                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14489                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14490                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14491                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14492                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14493                 ecosap=ecosa1+ecosa2
14494                 ecosbp=ecosb1+ecosb2
14495                 ecosgp=ecosg1+ecosg2
14496                 ecosam=ecosa1-ecosa2
14497                 ecosbm=ecosb1-ecosb2
14498                 ecosgm=ecosg1-ecosg2
14499 ! Diagnostics
14500 !               ecosap=ecosa1
14501 !               ecosbp=ecosb1
14502 !               ecosgp=ecosg1
14503 !               ecosam=0.0D0
14504 !               ecosbm=0.0D0
14505 !               ecosgm=0.0D0
14506 ! End diagnostics
14507                 facont_hb(num_conti,i)=fcont
14508                 fprimcont=fprimcont/rij
14509 !d              facont_hb(num_conti,i)=1.0D0
14510 ! Following line is for diagnostics.
14511 !d              fprimcont=0.0D0
14512                 do k=1,3
14513                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14514                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14515                 enddo
14516                 do k=1,3
14517                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14518                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14519                 enddo
14520 !                gggp(1)=gggp(1)+ees0pijp*xj
14521 !                gggp(2)=gggp(2)+ees0pijp*yj
14522 !                gggp(3)=gggp(3)+ees0pijp*zj
14523 !                gggm(1)=gggm(1)+ees0mijp*xj
14524 !                gggm(2)=gggm(2)+ees0mijp*yj
14525 !                gggm(3)=gggm(3)+ees0mijp*zj
14526                 gggp(1)=gggp(1)+ees0pijp*xj &
14527                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14528                 gggp(2)=gggp(2)+ees0pijp*yj &
14529                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14530                 gggp(3)=gggp(3)+ees0pijp*zj &
14531                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14532
14533                 gggm(1)=gggm(1)+ees0mijp*xj &
14534                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14535
14536                 gggm(2)=gggm(2)+ees0mijp*yj &
14537                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14538
14539                 gggm(3)=gggm(3)+ees0mijp*zj &
14540                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14541
14542 ! Derivatives due to the contact function
14543                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14544                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14545                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14546                 do k=1,3
14547 !
14548 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14549 !          following the change of gradient-summation algorithm.
14550 !
14551 !grad                  ghalfp=0.5D0*gggp(k)
14552 !grad                  ghalfm=0.5D0*gggm(k)
14553 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14554 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14555 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14556 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14557 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14558 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14559 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14560 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14561 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14562 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14563 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14564 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14565 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14566 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14567                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14568                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14569                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14570                      *sss_ele_cut
14571
14572                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14573                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14574                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14575                      *sss_ele_cut
14576
14577                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14578                      *sss_ele_cut
14579
14580                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14581                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14582                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14583                      *sss_ele_cut
14584
14585                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14586                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14587                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14588                      *sss_ele_cut
14589
14590                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14591                      *sss_ele_cut
14592
14593                 enddo
14594               ENDIF ! wcorr
14595               endif  ! num_conti.le.maxconts
14596             endif  ! fcont.gt.0
14597           endif    ! j.gt.i+1
14598           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14599             do k=1,4
14600               do l=1,3
14601                 ghalf=0.5d0*agg(l,k)
14602                 aggi(l,k)=aggi(l,k)+ghalf
14603                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14604                 aggj(l,k)=aggj(l,k)+ghalf
14605               enddo
14606             enddo
14607             if (j.eq.nres-1 .and. i.lt.j-2) then
14608               do k=1,4
14609                 do l=1,3
14610                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14611                 enddo
14612               enddo
14613             endif
14614           endif
14615  128      continue
14616 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14617       return
14618       end subroutine eelecij_scale
14619 !-----------------------------------------------------------------------------
14620       subroutine evdwpp_short(evdw1)
14621 !
14622 ! Compute Evdwpp
14623 !
14624 !      implicit real*8 (a-h,o-z)
14625 !      include 'DIMENSIONS'
14626 !      include 'COMMON.CONTROL'
14627 !      include 'COMMON.IOUNITS'
14628 !      include 'COMMON.GEO'
14629 !      include 'COMMON.VAR'
14630 !      include 'COMMON.LOCAL'
14631 !      include 'COMMON.CHAIN'
14632 !      include 'COMMON.DERIV'
14633 !      include 'COMMON.INTERACT'
14634 !      include 'COMMON.CONTACTS'
14635 !      include 'COMMON.TORSION'
14636 !      include 'COMMON.VECTORS'
14637 !      include 'COMMON.FFIELD'
14638       real(kind=8),dimension(3) :: ggg
14639 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14640 #ifdef MOMENT
14641       real(kind=8) :: scal_el=1.0d0
14642 #else
14643       real(kind=8) :: scal_el=0.5d0
14644 #endif
14645 !el local variables
14646       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14647       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14648       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14649                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14650                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14651       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14652                     dist_temp, dist_init,sss_grad
14653       integer xshift,yshift,zshift
14654
14655
14656       evdw1=0.0D0
14657 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14658 !     & " iatel_e_vdw",iatel_e_vdw
14659       call flush(iout)
14660       do i=iatel_s_vdw,iatel_e_vdw
14661         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
14662         dxi=dc(1,i)
14663         dyi=dc(2,i)
14664         dzi=dc(3,i)
14665         dx_normi=dc_norm(1,i)
14666         dy_normi=dc_norm(2,i)
14667         dz_normi=dc_norm(3,i)
14668         xmedi=c(1,i)+0.5d0*dxi
14669         ymedi=c(2,i)+0.5d0*dyi
14670         zmedi=c(3,i)+0.5d0*dzi
14671           xmedi=dmod(xmedi,boxxsize)
14672           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14673           ymedi=dmod(ymedi,boxysize)
14674           if (ymedi.lt.0) ymedi=ymedi+boxysize
14675           zmedi=dmod(zmedi,boxzsize)
14676           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14677         num_conti=0
14678 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14679 !     &   ' ielend',ielend_vdw(i)
14680         call flush(iout)
14681         do j=ielstart_vdw(i),ielend_vdw(i)
14682           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14683 !el          ind=ind+1
14684           iteli=itel(i)
14685           itelj=itel(j)
14686           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14687           aaa=app(iteli,itelj)
14688           bbb=bpp(iteli,itelj)
14689           dxj=dc(1,j)
14690           dyj=dc(2,j)
14691           dzj=dc(3,j)
14692           dx_normj=dc_norm(1,j)
14693           dy_normj=dc_norm(2,j)
14694           dz_normj=dc_norm(3,j)
14695 !          xj=c(1,j)+0.5D0*dxj-xmedi
14696 !          yj=c(2,j)+0.5D0*dyj-ymedi
14697 !          zj=c(3,j)+0.5D0*dzj-zmedi
14698           xj=c(1,j)+0.5D0*dxj
14699           yj=c(2,j)+0.5D0*dyj
14700           zj=c(3,j)+0.5D0*dzj
14701           xj=mod(xj,boxxsize)
14702           if (xj.lt.0) xj=xj+boxxsize
14703           yj=mod(yj,boxysize)
14704           if (yj.lt.0) yj=yj+boxysize
14705           zj=mod(zj,boxzsize)
14706           if (zj.lt.0) zj=zj+boxzsize
14707       isubchap=0
14708       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14709       xj_safe=xj
14710       yj_safe=yj
14711       zj_safe=zj
14712       do xshift=-1,1
14713       do yshift=-1,1
14714       do zshift=-1,1
14715           xj=xj_safe+xshift*boxxsize
14716           yj=yj_safe+yshift*boxysize
14717           zj=zj_safe+zshift*boxzsize
14718           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14719           if(dist_temp.lt.dist_init) then
14720             dist_init=dist_temp
14721             xj_temp=xj
14722             yj_temp=yj
14723             zj_temp=zj
14724             isubchap=1
14725           endif
14726        enddo
14727        enddo
14728        enddo
14729        if (isubchap.eq.1) then
14730 !C          print *,i,j
14731           xj=xj_temp-xmedi
14732           yj=yj_temp-ymedi
14733           zj=zj_temp-zmedi
14734        else
14735           xj=xj_safe-xmedi
14736           yj=yj_safe-ymedi
14737           zj=zj_safe-zmedi
14738        endif
14739
14740           rij=xj*xj+yj*yj+zj*zj
14741           rrmij=1.0D0/rij
14742           rij=dsqrt(rij)
14743           sss=sscale(rij/rpp(iteli,itelj))
14744             sss_ele_cut=sscale_ele(rij)
14745             sss_ele_grad=sscagrad_ele(rij)
14746             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14747             if (sss_ele_cut.le.0.0) cycle
14748           if (sss.gt.0.0d0) then
14749             rmij=1.0D0/rij
14750             r3ij=rrmij*rmij
14751             r6ij=r3ij*r3ij
14752             ev1=aaa*r6ij*r6ij
14753 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14754             if (j.eq.i+2) ev1=scal_el*ev1
14755             ev2=bbb*r6ij
14756             evdwij=ev1+ev2
14757             if (energy_dec) then
14758               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14759             endif
14760             evdw1=evdw1+evdwij*sss*sss_ele_cut
14761 !
14762 ! Calculate contributions to the Cartesian gradient.
14763 !
14764             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
14765 !            ggg(1)=facvdw*xj
14766 !            ggg(2)=facvdw*yj
14767 !            ggg(3)=facvdw*zj
14768           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
14769           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14770           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
14771           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14772           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
14773           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14774
14775             do k=1,3
14776               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14777               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14778             enddo
14779           endif
14780         enddo ! j
14781       enddo   ! i
14782       return
14783       end subroutine evdwpp_short
14784 !-----------------------------------------------------------------------------
14785       subroutine escp_long(evdw2,evdw2_14)
14786 !
14787 ! This subroutine calculates the excluded-volume interaction energy between
14788 ! peptide-group centers and side chains and its gradient in virtual-bond and
14789 ! side-chain vectors.
14790 !
14791 !      implicit real*8 (a-h,o-z)
14792 !      include 'DIMENSIONS'
14793 !      include 'COMMON.GEO'
14794 !      include 'COMMON.VAR'
14795 !      include 'COMMON.LOCAL'
14796 !      include 'COMMON.CHAIN'
14797 !      include 'COMMON.DERIV'
14798 !      include 'COMMON.INTERACT'
14799 !      include 'COMMON.FFIELD'
14800 !      include 'COMMON.IOUNITS'
14801 !      include 'COMMON.CONTROL'
14802       real(kind=8),dimension(3) :: ggg
14803 !el local variables
14804       integer :: i,iint,j,k,iteli,itypj,subchap
14805       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
14806       real(kind=8) :: evdw2,evdw2_14,evdwij
14807       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14808                     dist_temp, dist_init
14809
14810       evdw2=0.0D0
14811       evdw2_14=0.0d0
14812 !d    print '(a)','Enter ESCP'
14813 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
14814       do i=iatscp_s,iatscp_e
14815         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14816         iteli=itel(i)
14817         xi=0.5D0*(c(1,i)+c(1,i+1))
14818         yi=0.5D0*(c(2,i)+c(2,i+1))
14819         zi=0.5D0*(c(3,i)+c(3,i+1))
14820           xi=mod(xi,boxxsize)
14821           if (xi.lt.0) xi=xi+boxxsize
14822           yi=mod(yi,boxysize)
14823           if (yi.lt.0) yi=yi+boxysize
14824           zi=mod(zi,boxzsize)
14825           if (zi.lt.0) zi=zi+boxzsize
14826
14827         do iint=1,nscp_gr(i)
14828
14829         do j=iscpstart(i,iint),iscpend(i,iint)
14830           itypj=itype(j,1)
14831           if (itypj.eq.ntyp1) cycle
14832 ! Uncomment following three lines for SC-p interactions
14833 !         xj=c(1,nres+j)-xi
14834 !         yj=c(2,nres+j)-yi
14835 !         zj=c(3,nres+j)-zi
14836 ! Uncomment following three lines for Ca-p interactions
14837           xj=c(1,j)
14838           yj=c(2,j)
14839           zj=c(3,j)
14840           xj=mod(xj,boxxsize)
14841           if (xj.lt.0) xj=xj+boxxsize
14842           yj=mod(yj,boxysize)
14843           if (yj.lt.0) yj=yj+boxysize
14844           zj=mod(zj,boxzsize)
14845           if (zj.lt.0) zj=zj+boxzsize
14846       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14847       xj_safe=xj
14848       yj_safe=yj
14849       zj_safe=zj
14850       subchap=0
14851       do xshift=-1,1
14852       do yshift=-1,1
14853       do zshift=-1,1
14854           xj=xj_safe+xshift*boxxsize
14855           yj=yj_safe+yshift*boxysize
14856           zj=zj_safe+zshift*boxzsize
14857           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14858           if(dist_temp.lt.dist_init) then
14859             dist_init=dist_temp
14860             xj_temp=xj
14861             yj_temp=yj
14862             zj_temp=zj
14863             subchap=1
14864           endif
14865        enddo
14866        enddo
14867        enddo
14868        if (subchap.eq.1) then
14869           xj=xj_temp-xi
14870           yj=yj_temp-yi
14871           zj=zj_temp-zi
14872        else
14873           xj=xj_safe-xi
14874           yj=yj_safe-yi
14875           zj=zj_safe-zi
14876        endif
14877           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14878
14879           rij=dsqrt(1.0d0/rrij)
14880             sss_ele_cut=sscale_ele(rij)
14881             sss_ele_grad=sscagrad_ele(rij)
14882 !            print *,sss_ele_cut,sss_ele_grad,&
14883 !            (rij),r_cut_ele,rlamb_ele
14884             if (sss_ele_cut.le.0.0) cycle
14885           sss=sscale((rij/rscp(itypj,iteli)))
14886           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
14887           if (sss.lt.1.0d0) then
14888
14889             fac=rrij**expon2
14890             e1=fac*fac*aad(itypj,iteli)
14891             e2=fac*bad(itypj,iteli)
14892             if (iabs(j-i) .le. 2) then
14893               e1=scal14*e1
14894               e2=scal14*e2
14895               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
14896             endif
14897             evdwij=e1+e2
14898             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
14899             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
14900                 'evdw2',i,j,sss,evdwij
14901 !
14902 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
14903 !
14904             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
14905             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
14906             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
14907             ggg(1)=xj*fac
14908             ggg(2)=yj*fac
14909             ggg(3)=zj*fac
14910 ! Uncomment following three lines for SC-p interactions
14911 !           do k=1,3
14912 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14913 !           enddo
14914 ! Uncomment following line for SC-p interactions
14915 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14916             do k=1,3
14917               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
14918               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
14919             enddo
14920           endif
14921         enddo
14922
14923         enddo ! iint
14924       enddo ! i
14925       do i=1,nct
14926         do j=1,3
14927           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
14928           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
14929           gradx_scp(j,i)=expon*gradx_scp(j,i)
14930         enddo
14931       enddo
14932 !******************************************************************************
14933 !
14934 !                              N O T E !!!
14935 !
14936 ! To save time the factor EXPON has been extracted from ALL components
14937 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14938 ! use!
14939 !
14940 !******************************************************************************
14941       return
14942       end subroutine escp_long
14943 !-----------------------------------------------------------------------------
14944       subroutine escp_short(evdw2,evdw2_14)
14945 !
14946 ! This subroutine calculates the excluded-volume interaction energy between
14947 ! peptide-group centers and side chains and its gradient in virtual-bond and
14948 ! side-chain vectors.
14949 !
14950 !      implicit real*8 (a-h,o-z)
14951 !      include 'DIMENSIONS'
14952 !      include 'COMMON.GEO'
14953 !      include 'COMMON.VAR'
14954 !      include 'COMMON.LOCAL'
14955 !      include 'COMMON.CHAIN'
14956 !      include 'COMMON.DERIV'
14957 !      include 'COMMON.INTERACT'
14958 !      include 'COMMON.FFIELD'
14959 !      include 'COMMON.IOUNITS'
14960 !      include 'COMMON.CONTROL'
14961       real(kind=8),dimension(3) :: ggg
14962 !el local variables
14963       integer :: i,iint,j,k,iteli,itypj,subchap
14964       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
14965       real(kind=8) :: evdw2,evdw2_14,evdwij
14966       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14967                     dist_temp, dist_init
14968
14969       evdw2=0.0D0
14970       evdw2_14=0.0d0
14971 !d    print '(a)','Enter ESCP'
14972 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
14973       do i=iatscp_s,iatscp_e
14974         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14975         iteli=itel(i)
14976         xi=0.5D0*(c(1,i)+c(1,i+1))
14977         yi=0.5D0*(c(2,i)+c(2,i+1))
14978         zi=0.5D0*(c(3,i)+c(3,i+1))
14979           xi=mod(xi,boxxsize)
14980           if (xi.lt.0) xi=xi+boxxsize
14981           yi=mod(yi,boxysize)
14982           if (yi.lt.0) yi=yi+boxysize
14983           zi=mod(zi,boxzsize)
14984           if (zi.lt.0) zi=zi+boxzsize
14985
14986         do iint=1,nscp_gr(i)
14987
14988         do j=iscpstart(i,iint),iscpend(i,iint)
14989           itypj=itype(j,1)
14990           if (itypj.eq.ntyp1) cycle
14991 ! Uncomment following three lines for SC-p interactions
14992 !         xj=c(1,nres+j)-xi
14993 !         yj=c(2,nres+j)-yi
14994 !         zj=c(3,nres+j)-zi
14995 ! Uncomment following three lines for Ca-p interactions
14996 !          xj=c(1,j)-xi
14997 !          yj=c(2,j)-yi
14998 !          zj=c(3,j)-zi
14999           xj=c(1,j)
15000           yj=c(2,j)
15001           zj=c(3,j)
15002           xj=mod(xj,boxxsize)
15003           if (xj.lt.0) xj=xj+boxxsize
15004           yj=mod(yj,boxysize)
15005           if (yj.lt.0) yj=yj+boxysize
15006           zj=mod(zj,boxzsize)
15007           if (zj.lt.0) zj=zj+boxzsize
15008       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15009       xj_safe=xj
15010       yj_safe=yj
15011       zj_safe=zj
15012       subchap=0
15013       do xshift=-1,1
15014       do yshift=-1,1
15015       do zshift=-1,1
15016           xj=xj_safe+xshift*boxxsize
15017           yj=yj_safe+yshift*boxysize
15018           zj=zj_safe+zshift*boxzsize
15019           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15020           if(dist_temp.lt.dist_init) then
15021             dist_init=dist_temp
15022             xj_temp=xj
15023             yj_temp=yj
15024             zj_temp=zj
15025             subchap=1
15026           endif
15027        enddo
15028        enddo
15029        enddo
15030        if (subchap.eq.1) then
15031           xj=xj_temp-xi
15032           yj=yj_temp-yi
15033           zj=zj_temp-zi
15034        else
15035           xj=xj_safe-xi
15036           yj=yj_safe-yi
15037           zj=zj_safe-zi
15038        endif
15039
15040           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15041           rij=dsqrt(1.0d0/rrij)
15042             sss_ele_cut=sscale_ele(rij)
15043             sss_ele_grad=sscagrad_ele(rij)
15044 !            print *,sss_ele_cut,sss_ele_grad,&
15045 !            (rij),r_cut_ele,rlamb_ele
15046             if (sss_ele_cut.le.0.0) cycle
15047           sss=sscale(rij/rscp(itypj,iteli))
15048           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15049           if (sss.gt.0.0d0) then
15050
15051             fac=rrij**expon2
15052             e1=fac*fac*aad(itypj,iteli)
15053             e2=fac*bad(itypj,iteli)
15054             if (iabs(j-i) .le. 2) then
15055               e1=scal14*e1
15056               e2=scal14*e2
15057               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15058             endif
15059             evdwij=e1+e2
15060             evdw2=evdw2+evdwij*sss*sss_ele_cut
15061             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15062                 'evdw2',i,j,sss,evdwij
15063 !
15064 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15065 !
15066             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15067             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15068             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15069
15070             ggg(1)=xj*fac
15071             ggg(2)=yj*fac
15072             ggg(3)=zj*fac
15073 ! Uncomment following three lines for SC-p interactions
15074 !           do k=1,3
15075 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15076 !           enddo
15077 ! Uncomment following line for SC-p interactions
15078 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15079             do k=1,3
15080               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15081               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15082             enddo
15083           endif
15084         enddo
15085
15086         enddo ! iint
15087       enddo ! i
15088       do i=1,nct
15089         do j=1,3
15090           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15091           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15092           gradx_scp(j,i)=expon*gradx_scp(j,i)
15093         enddo
15094       enddo
15095 !******************************************************************************
15096 !
15097 !                              N O T E !!!
15098 !
15099 ! To save time the factor EXPON has been extracted from ALL components
15100 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15101 ! use!
15102 !
15103 !******************************************************************************
15104       return
15105       end subroutine escp_short
15106 !-----------------------------------------------------------------------------
15107 ! energy_p_new-sep_barrier.F
15108 !-----------------------------------------------------------------------------
15109       subroutine sc_grad_scale(scalfac)
15110 !      implicit real*8 (a-h,o-z)
15111       use calc_data
15112 !      include 'DIMENSIONS'
15113 !      include 'COMMON.CHAIN'
15114 !      include 'COMMON.DERIV'
15115 !      include 'COMMON.CALC'
15116 !      include 'COMMON.IOUNITS'
15117       real(kind=8),dimension(3) :: dcosom1,dcosom2
15118       real(kind=8) :: scalfac
15119 !el local variables
15120 !      integer :: i,j,k,l
15121
15122       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15123       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15124       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15125            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15126 ! diagnostics only
15127 !      eom1=0.0d0
15128 !      eom2=0.0d0
15129 !      eom12=evdwij*eps1_om12
15130 ! end diagnostics
15131 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15132 !     &  " sigder",sigder
15133 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15134 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15135       do k=1,3
15136         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15137         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15138       enddo
15139       do k=1,3
15140         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15141          *sss_ele_cut
15142       enddo
15143 !      write (iout,*) "gg",(gg(k),k=1,3)
15144       do k=1,3
15145         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15146                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15147                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15148                  *sss_ele_cut
15149         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15150                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15151                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15152          *sss_ele_cut
15153 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15154 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15155 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15156 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15157       enddo
15158 !
15159 ! Calculate the components of the gradient in DC and X
15160 !
15161       do l=1,3
15162         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15163         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15164       enddo
15165       return
15166       end subroutine sc_grad_scale
15167 !-----------------------------------------------------------------------------
15168 ! energy_split-sep.F
15169 !-----------------------------------------------------------------------------
15170       subroutine etotal_long(energia)
15171 !
15172 ! Compute the long-range slow-varying contributions to the energy
15173 !
15174 !      implicit real*8 (a-h,o-z)
15175 !      include 'DIMENSIONS'
15176       use MD_data, only: totT,usampl,eq_time
15177 #ifndef ISNAN
15178       external proc_proc
15179 #ifdef WINPGI
15180 !MS$ATTRIBUTES C ::  proc_proc
15181 #endif
15182 #endif
15183 #ifdef MPI
15184       include "mpif.h"
15185       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15186 #endif
15187 !      include 'COMMON.SETUP'
15188 !      include 'COMMON.IOUNITS'
15189 !      include 'COMMON.FFIELD'
15190 !      include 'COMMON.DERIV'
15191 !      include 'COMMON.INTERACT'
15192 !      include 'COMMON.SBRIDGE'
15193 !      include 'COMMON.CHAIN'
15194 !      include 'COMMON.VAR'
15195 !      include 'COMMON.LOCAL'
15196 !      include 'COMMON.MD'
15197       real(kind=8),dimension(0:n_ene) :: energia
15198 !el local variables
15199       integer :: i,n_corr,n_corr1,ierror,ierr
15200       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15201                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15202                   ecorr,ecorr5,ecorr6,eturn6,time00
15203 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15204 !elwrite(iout,*)"in etotal long"
15205
15206       if (modecalc.eq.12.or.modecalc.eq.14) then
15207 #ifdef MPI
15208 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15209 #else
15210         call int_from_cart1(.false.)
15211 #endif
15212       endif
15213 !elwrite(iout,*)"in etotal long"
15214
15215 #ifdef MPI
15216 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15217 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15218       call flush(iout)
15219       if (nfgtasks.gt.1) then
15220         time00=MPI_Wtime()
15221 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15222         if (fg_rank.eq.0) then
15223           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15224 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15225 !          call flush(iout)
15226 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15227 ! FG slaves as WEIGHTS array.
15228           weights_(1)=wsc
15229           weights_(2)=wscp
15230           weights_(3)=welec
15231           weights_(4)=wcorr
15232           weights_(5)=wcorr5
15233           weights_(6)=wcorr6
15234           weights_(7)=wel_loc
15235           weights_(8)=wturn3
15236           weights_(9)=wturn4
15237           weights_(10)=wturn6
15238           weights_(11)=wang
15239           weights_(12)=wscloc
15240           weights_(13)=wtor
15241           weights_(14)=wtor_d
15242           weights_(15)=wstrain
15243           weights_(16)=wvdwpp
15244           weights_(17)=wbond
15245           weights_(18)=scal14
15246           weights_(21)=wsccor
15247 ! FG Master broadcasts the WEIGHTS_ array
15248           call MPI_Bcast(weights_(1),n_ene,&
15249               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15250         else
15251 ! FG slaves receive the WEIGHTS array
15252           call MPI_Bcast(weights(1),n_ene,&
15253               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15254           wsc=weights(1)
15255           wscp=weights(2)
15256           welec=weights(3)
15257           wcorr=weights(4)
15258           wcorr5=weights(5)
15259           wcorr6=weights(6)
15260           wel_loc=weights(7)
15261           wturn3=weights(8)
15262           wturn4=weights(9)
15263           wturn6=weights(10)
15264           wang=weights(11)
15265           wscloc=weights(12)
15266           wtor=weights(13)
15267           wtor_d=weights(14)
15268           wstrain=weights(15)
15269           wvdwpp=weights(16)
15270           wbond=weights(17)
15271           scal14=weights(18)
15272           wsccor=weights(21)
15273         endif
15274         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15275           king,FG_COMM,IERR)
15276          time_Bcast=time_Bcast+MPI_Wtime()-time00
15277          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15278 !        call chainbuild_cart
15279 !        call int_from_cart1(.false.)
15280       endif
15281 !      write (iout,*) 'Processor',myrank,
15282 !     &  ' calling etotal_short ipot=',ipot
15283 !      call flush(iout)
15284 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15285 #endif
15286 !d    print *,'nnt=',nnt,' nct=',nct
15287 !
15288 !elwrite(iout,*)"in etotal long"
15289 ! Compute the side-chain and electrostatic interaction energy
15290 !
15291       goto (101,102,103,104,105,106) ipot
15292 ! Lennard-Jones potential.
15293   101 call elj_long(evdw)
15294 !d    print '(a)','Exit ELJ'
15295       goto 107
15296 ! Lennard-Jones-Kihara potential (shifted).
15297   102 call eljk_long(evdw)
15298       goto 107
15299 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15300   103 call ebp_long(evdw)
15301       goto 107
15302 ! Gay-Berne potential (shifted LJ, angular dependence).
15303   104 call egb_long(evdw)
15304       goto 107
15305 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15306   105 call egbv_long(evdw)
15307       goto 107
15308 ! Soft-sphere potential
15309   106 call e_softsphere(evdw)
15310 !
15311 ! Calculate electrostatic (H-bonding) energy of the main chain.
15312 !
15313   107 continue
15314       call vec_and_deriv
15315       if (ipot.lt.6) then
15316 #ifdef SPLITELE
15317          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15318              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15319              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15320              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15321 #else
15322          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15323              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15324              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15325              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15326 #endif
15327            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15328          else
15329             ees=0
15330             evdw1=0
15331             eel_loc=0
15332             eello_turn3=0
15333             eello_turn4=0
15334          endif
15335       else
15336 !        write (iout,*) "Soft-spheer ELEC potential"
15337         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15338          eello_turn4)
15339       endif
15340 !
15341 ! Calculate excluded-volume interaction energy between peptide groups
15342 ! and side chains.
15343 !
15344       if (ipot.lt.6) then
15345        if(wscp.gt.0d0) then
15346         call escp_long(evdw2,evdw2_14)
15347        else
15348         evdw2=0
15349         evdw2_14=0
15350        endif
15351       else
15352         call escp_soft_sphere(evdw2,evdw2_14)
15353       endif
15354 !
15355 ! 12/1/95 Multi-body terms
15356 !
15357       n_corr=0
15358       n_corr1=0
15359       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15360           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15361          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15362 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15363 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15364       else
15365          ecorr=0.0d0
15366          ecorr5=0.0d0
15367          ecorr6=0.0d0
15368          eturn6=0.0d0
15369       endif
15370       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15371          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15372       endif
15373 !
15374 ! If performing constraint dynamics, call the constraint energy
15375 !  after the equilibration time
15376       if(usampl.and.totT.gt.eq_time) then
15377          call EconstrQ
15378          call Econstr_back
15379       else
15380          Uconst=0.0d0
15381          Uconst_back=0.0d0
15382       endif
15383 !
15384 ! Sum the energies
15385 !
15386       do i=1,n_ene
15387         energia(i)=0.0d0
15388       enddo
15389       energia(1)=evdw
15390 #ifdef SCP14
15391       energia(2)=evdw2-evdw2_14
15392       energia(18)=evdw2_14
15393 #else
15394       energia(2)=evdw2
15395       energia(18)=0.0d0
15396 #endif
15397 #ifdef SPLITELE
15398       energia(3)=ees
15399       energia(16)=evdw1
15400 #else
15401       energia(3)=ees+evdw1
15402       energia(16)=0.0d0
15403 #endif
15404       energia(4)=ecorr
15405       energia(5)=ecorr5
15406       energia(6)=ecorr6
15407       energia(7)=eel_loc
15408       energia(8)=eello_turn3
15409       energia(9)=eello_turn4
15410       energia(10)=eturn6
15411       energia(20)=Uconst+Uconst_back
15412       call sum_energy(energia,.true.)
15413 !      write (iout,*) "Exit ETOTAL_LONG"
15414       call flush(iout)
15415       return
15416       end subroutine etotal_long
15417 !-----------------------------------------------------------------------------
15418       subroutine etotal_short(energia)
15419 !
15420 ! Compute the short-range fast-varying contributions to the energy
15421 !
15422 !      implicit real*8 (a-h,o-z)
15423 !      include 'DIMENSIONS'
15424 #ifndef ISNAN
15425       external proc_proc
15426 #ifdef WINPGI
15427 !MS$ATTRIBUTES C ::  proc_proc
15428 #endif
15429 #endif
15430 #ifdef MPI
15431       include "mpif.h"
15432       integer :: ierror,ierr
15433       real(kind=8),dimension(n_ene) :: weights_
15434       real(kind=8) :: time00
15435 #endif
15436 !      include 'COMMON.SETUP'
15437 !      include 'COMMON.IOUNITS'
15438 !      include 'COMMON.FFIELD'
15439 !      include 'COMMON.DERIV'
15440 !      include 'COMMON.INTERACT'
15441 !      include 'COMMON.SBRIDGE'
15442 !      include 'COMMON.CHAIN'
15443 !      include 'COMMON.VAR'
15444 !      include 'COMMON.LOCAL'
15445       real(kind=8),dimension(0:n_ene) :: energia
15446 !el local variables
15447       integer :: i,nres6
15448       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15449       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15450       nres6=6*nres
15451
15452 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15453 !      call flush(iout)
15454       if (modecalc.eq.12.or.modecalc.eq.14) then
15455 #ifdef MPI
15456         if (fg_rank.eq.0) call int_from_cart1(.false.)
15457 #else
15458         call int_from_cart1(.false.)
15459 #endif
15460       endif
15461 #ifdef MPI
15462 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15463 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15464 !      call flush(iout)
15465       if (nfgtasks.gt.1) then
15466         time00=MPI_Wtime()
15467 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15468         if (fg_rank.eq.0) then
15469           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15470 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15471 !          call flush(iout)
15472 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15473 ! FG slaves as WEIGHTS array.
15474           weights_(1)=wsc
15475           weights_(2)=wscp
15476           weights_(3)=welec
15477           weights_(4)=wcorr
15478           weights_(5)=wcorr5
15479           weights_(6)=wcorr6
15480           weights_(7)=wel_loc
15481           weights_(8)=wturn3
15482           weights_(9)=wturn4
15483           weights_(10)=wturn6
15484           weights_(11)=wang
15485           weights_(12)=wscloc
15486           weights_(13)=wtor
15487           weights_(14)=wtor_d
15488           weights_(15)=wstrain
15489           weights_(16)=wvdwpp
15490           weights_(17)=wbond
15491           weights_(18)=scal14
15492           weights_(21)=wsccor
15493 ! FG Master broadcasts the WEIGHTS_ array
15494           call MPI_Bcast(weights_(1),n_ene,&
15495               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15496         else
15497 ! FG slaves receive the WEIGHTS array
15498           call MPI_Bcast(weights(1),n_ene,&
15499               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15500           wsc=weights(1)
15501           wscp=weights(2)
15502           welec=weights(3)
15503           wcorr=weights(4)
15504           wcorr5=weights(5)
15505           wcorr6=weights(6)
15506           wel_loc=weights(7)
15507           wturn3=weights(8)
15508           wturn4=weights(9)
15509           wturn6=weights(10)
15510           wang=weights(11)
15511           wscloc=weights(12)
15512           wtor=weights(13)
15513           wtor_d=weights(14)
15514           wstrain=weights(15)
15515           wvdwpp=weights(16)
15516           wbond=weights(17)
15517           scal14=weights(18)
15518           wsccor=weights(21)
15519         endif
15520 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15521         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15522           king,FG_COMM,IERR)
15523 !        write (iout,*) "Processor",myrank," BROADCAST c"
15524         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15525           king,FG_COMM,IERR)
15526 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15527         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15528           king,FG_COMM,IERR)
15529 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15530         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15531           king,FG_COMM,IERR)
15532 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15533         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15534           king,FG_COMM,IERR)
15535 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15536         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15537           king,FG_COMM,IERR)
15538 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15539         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15540           king,FG_COMM,IERR)
15541 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15542         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15543           king,FG_COMM,IERR)
15544 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15545         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15546           king,FG_COMM,IERR)
15547          time_Bcast=time_Bcast+MPI_Wtime()-time00
15548 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15549       endif
15550 !      write (iout,*) 'Processor',myrank,
15551 !     &  ' calling etotal_short ipot=',ipot
15552 !      call flush(iout)
15553 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15554 #endif
15555 !      call int_from_cart1(.false.)
15556 !
15557 ! Compute the side-chain and electrostatic interaction energy
15558 !
15559       goto (101,102,103,104,105,106) ipot
15560 ! Lennard-Jones potential.
15561   101 call elj_short(evdw)
15562 !d    print '(a)','Exit ELJ'
15563       goto 107
15564 ! Lennard-Jones-Kihara potential (shifted).
15565   102 call eljk_short(evdw)
15566       goto 107
15567 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15568   103 call ebp_short(evdw)
15569       goto 107
15570 ! Gay-Berne potential (shifted LJ, angular dependence).
15571   104 call egb_short(evdw)
15572       goto 107
15573 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15574   105 call egbv_short(evdw)
15575       goto 107
15576 ! Soft-sphere potential - already dealt with in the long-range part
15577   106 evdw=0.0d0
15578 !  106 call e_softsphere_short(evdw)
15579 !
15580 ! Calculate electrostatic (H-bonding) energy of the main chain.
15581 !
15582   107 continue
15583 !
15584 ! Calculate the short-range part of Evdwpp
15585 !
15586       call evdwpp_short(evdw1)
15587 !
15588 ! Calculate the short-range part of ESCp
15589 !
15590       if (ipot.lt.6) then
15591         call escp_short(evdw2,evdw2_14)
15592       endif
15593 !
15594 ! Calculate the bond-stretching energy
15595 !
15596       call ebond(estr)
15597 !
15598 ! Calculate the disulfide-bridge and other energy and the contributions
15599 ! from other distance constraints.
15600       call edis(ehpb)
15601 !
15602 ! Calculate the virtual-bond-angle energy.
15603 !
15604       call ebend(ebe,ethetacnstr)
15605 !
15606 ! Calculate the SC local energy.
15607 !
15608       call vec_and_deriv
15609       call esc(escloc)
15610 !
15611 ! Calculate the virtual-bond torsional energy.
15612 !
15613       call etor(etors,edihcnstr)
15614 !
15615 ! 6/23/01 Calculate double-torsional energy
15616 !
15617       call etor_d(etors_d)
15618 !
15619 ! 21/5/07 Calculate local sicdechain correlation energy
15620 !
15621       if (wsccor.gt.0.0d0) then
15622         call eback_sc_corr(esccor)
15623       else
15624         esccor=0.0d0
15625       endif
15626 !
15627 ! Put energy components into an array
15628 !
15629       do i=1,n_ene
15630         energia(i)=0.0d0
15631       enddo
15632       energia(1)=evdw
15633 #ifdef SCP14
15634       energia(2)=evdw2-evdw2_14
15635       energia(18)=evdw2_14
15636 #else
15637       energia(2)=evdw2
15638       energia(18)=0.0d0
15639 #endif
15640 #ifdef SPLITELE
15641       energia(16)=evdw1
15642 #else
15643       energia(3)=evdw1
15644 #endif
15645       energia(11)=ebe
15646       energia(12)=escloc
15647       energia(13)=etors
15648       energia(14)=etors_d
15649       energia(15)=ehpb
15650       energia(17)=estr
15651       energia(19)=edihcnstr
15652       energia(21)=esccor
15653 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15654       call flush(iout)
15655       call sum_energy(energia,.true.)
15656 !      write (iout,*) "Exit ETOTAL_SHORT"
15657       call flush(iout)
15658       return
15659       end subroutine etotal_short
15660 !-----------------------------------------------------------------------------
15661 ! gnmr1.f
15662 !-----------------------------------------------------------------------------
15663       real(kind=8) function gnmr1(y,ymin,ymax)
15664 !      implicit none
15665       real(kind=8) :: y,ymin,ymax
15666       real(kind=8) :: wykl=4.0d0
15667       if (y.lt.ymin) then
15668         gnmr1=(ymin-y)**wykl/wykl
15669       else if (y.gt.ymax) then
15670         gnmr1=(y-ymax)**wykl/wykl
15671       else
15672         gnmr1=0.0d0
15673       endif
15674       return
15675       end function gnmr1
15676 !-----------------------------------------------------------------------------
15677       real(kind=8) function gnmr1prim(y,ymin,ymax)
15678 !      implicit none
15679       real(kind=8) :: y,ymin,ymax
15680       real(kind=8) :: wykl=4.0d0
15681       if (y.lt.ymin) then
15682         gnmr1prim=-(ymin-y)**(wykl-1)
15683       else if (y.gt.ymax) then
15684         gnmr1prim=(y-ymax)**(wykl-1)
15685       else
15686         gnmr1prim=0.0d0
15687       endif
15688       return
15689       end function gnmr1prim
15690 !----------------------------------------------------------------------------
15691       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
15692       real(kind=8) y,ymin,ymax,sigma
15693       real(kind=8) wykl /4.0d0/
15694       if (y.lt.ymin) then
15695         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
15696       else if (y.gt.ymax) then
15697         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
15698       else
15699         rlornmr1=0.0d0
15700       endif
15701       return
15702       end function rlornmr1
15703 !------------------------------------------------------------------------------
15704       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
15705       real(kind=8) y,ymin,ymax,sigma
15706       real(kind=8) wykl /4.0d0/
15707       if (y.lt.ymin) then
15708         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
15709         ((ymin-y)**wykl+sigma**wykl)**2
15710       else if (y.gt.ymax) then
15711         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
15712         ((y-ymax)**wykl+sigma**wykl)**2
15713       else
15714         rlornmr1prim=0.0d0
15715       endif
15716       return
15717       end function rlornmr1prim
15718
15719       real(kind=8) function harmonic(y,ymax)
15720 !      implicit none
15721       real(kind=8) :: y,ymax
15722       real(kind=8) :: wykl=2.0d0
15723       harmonic=(y-ymax)**wykl
15724       return
15725       end function harmonic
15726 !-----------------------------------------------------------------------------
15727       real(kind=8) function harmonicprim(y,ymax)
15728       real(kind=8) :: y,ymin,ymax
15729       real(kind=8) :: wykl=2.0d0
15730       harmonicprim=(y-ymax)*wykl
15731       return
15732       end function harmonicprim
15733 !-----------------------------------------------------------------------------
15734 ! gradient_p.F
15735 !-----------------------------------------------------------------------------
15736       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
15737
15738       use io_base, only:intout,briefout
15739 !      implicit real*8 (a-h,o-z)
15740 !      include 'DIMENSIONS'
15741 !      include 'COMMON.CHAIN'
15742 !      include 'COMMON.DERIV'
15743 !      include 'COMMON.VAR'
15744 !      include 'COMMON.INTERACT'
15745 !      include 'COMMON.FFIELD'
15746 !      include 'COMMON.MD'
15747 !      include 'COMMON.IOUNITS'
15748       real(kind=8),external :: ufparm
15749       integer :: uiparm(1)
15750       real(kind=8) :: urparm(1)
15751       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
15752       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
15753       integer :: n,nf,ind,ind1,i,k,j
15754 !
15755 ! This subroutine calculates total internal coordinate gradient.
15756 ! Depending on the number of function evaluations, either whole energy
15757 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
15758 ! internal coordinates are reevaluated or only the cartesian-in-internal
15759 ! coordinate derivatives are evaluated. The subroutine was designed to work
15760 ! with SUMSL.
15761 !
15762 !
15763       icg=mod(nf,2)+1
15764
15765 !d      print *,'grad',nf,icg
15766       if (nf-nfl+1) 20,30,40
15767    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
15768 !    write (iout,*) 'grad 20'
15769       if (nf.eq.0) return
15770       goto 40
15771    30 call var_to_geom(n,x)
15772       call chainbuild
15773 !    write (iout,*) 'grad 30'
15774 !
15775 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
15776 !
15777    40 call cartder
15778 !     write (iout,*) 'grad 40'
15779 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
15780 !
15781 ! Convert the Cartesian gradient into internal-coordinate gradient.
15782 !
15783       ind=0
15784       ind1=0
15785       do i=1,nres-2
15786         gthetai=0.0D0
15787         gphii=0.0D0
15788         do j=i+1,nres-1
15789           ind=ind+1
15790 !         ind=indmat(i,j)
15791 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
15792           do k=1,3
15793             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
15794           enddo
15795           do k=1,3
15796             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
15797           enddo
15798         enddo
15799         do j=i+1,nres-1
15800           ind1=ind1+1
15801 !         ind1=indmat(i,j)
15802 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
15803           do k=1,3
15804             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
15805             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
15806           enddo
15807         enddo
15808         if (i.gt.1) g(i-1)=gphii
15809         if (n.gt.nphi) g(nphi+i)=gthetai
15810       enddo
15811       if (n.le.nphi+ntheta) goto 10
15812       do i=2,nres-1
15813         if (itype(i,1).ne.10) then
15814           galphai=0.0D0
15815           gomegai=0.0D0
15816           do k=1,3
15817             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
15818           enddo
15819           do k=1,3
15820             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
15821           enddo
15822           g(ialph(i,1))=galphai
15823           g(ialph(i,1)+nside)=gomegai
15824         endif
15825       enddo
15826 !
15827 ! Add the components corresponding to local energy terms.
15828 !
15829    10 continue
15830       do i=1,nvar
15831 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
15832         g(i)=g(i)+gloc(i,icg)
15833       enddo
15834 ! Uncomment following three lines for diagnostics.
15835 !d    call intout
15836 !elwrite(iout,*) "in gradient after calling intout"
15837 !d    call briefout(0,0.0d0)
15838 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
15839       return
15840       end subroutine gradient
15841 !-----------------------------------------------------------------------------
15842       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
15843
15844       use comm_chu
15845 !      implicit real*8 (a-h,o-z)
15846 !      include 'DIMENSIONS'
15847 !      include 'COMMON.DERIV'
15848 !      include 'COMMON.IOUNITS'
15849 !      include 'COMMON.GEO'
15850       integer :: n,nf
15851 !el      integer :: jjj
15852 !el      common /chuju/ jjj
15853       real(kind=8) :: energia(0:n_ene)
15854       integer :: uiparm(1)
15855       real(kind=8) :: urparm(1)
15856       real(kind=8) :: f
15857       real(kind=8),external :: ufparm
15858       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
15859 !     if (jjj.gt.0) then
15860 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15861 !     endif
15862       nfl=nf
15863       icg=mod(nf,2)+1
15864 !d      print *,'func',nf,nfl,icg
15865       call var_to_geom(n,x)
15866       call zerograd
15867       call chainbuild
15868 !d    write (iout,*) 'ETOTAL called from FUNC'
15869       call etotal(energia)
15870       call sum_gradient
15871       f=energia(0)
15872 !     if (jjj.gt.0) then
15873 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15874 !       write (iout,*) 'f=',etot
15875 !       jjj=0
15876 !     endif
15877       return
15878       end subroutine func
15879 !-----------------------------------------------------------------------------
15880       subroutine cartgrad
15881 !      implicit real*8 (a-h,o-z)
15882 !      include 'DIMENSIONS'
15883       use energy_data
15884       use MD_data, only: totT,usampl,eq_time
15885 #ifdef MPI
15886       include 'mpif.h'
15887 #endif
15888 !      include 'COMMON.CHAIN'
15889 !      include 'COMMON.DERIV'
15890 !      include 'COMMON.VAR'
15891 !      include 'COMMON.INTERACT'
15892 !      include 'COMMON.FFIELD'
15893 !      include 'COMMON.MD'
15894 !      include 'COMMON.IOUNITS'
15895 !      include 'COMMON.TIME1'
15896 !
15897       integer :: i,j
15898
15899 ! This subrouting calculates total Cartesian coordinate gradient.
15900 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
15901 !
15902 !el#define DEBUG
15903 #ifdef TIMING
15904       time00=MPI_Wtime()
15905 #endif
15906       icg=1
15907       call sum_gradient
15908 #ifdef TIMING
15909 #endif
15910 !el      write (iout,*) "After sum_gradient"
15911 #ifdef DEBUG
15912 !el      write (iout,*) "After sum_gradient"
15913       do i=1,nres-1
15914         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
15915         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
15916       enddo
15917 #endif
15918 ! If performing constraint dynamics, add the gradients of the constraint energy
15919       if(usampl.and.totT.gt.eq_time) then
15920          do i=1,nct
15921            do j=1,3
15922              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
15923              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
15924            enddo
15925          enddo
15926          do i=1,nres-3
15927            gloc(i,icg)=gloc(i,icg)+dugamma(i)
15928          enddo
15929          do i=1,nres-2
15930            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
15931          enddo
15932       endif
15933 !elwrite (iout,*) "After sum_gradient"
15934 #ifdef TIMING
15935       time01=MPI_Wtime()
15936 #endif
15937       call intcartderiv
15938 !elwrite (iout,*) "After sum_gradient"
15939 #ifdef TIMING
15940       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
15941 #endif
15942 !     call checkintcartgrad
15943 !     write(iout,*) 'calling int_to_cart'
15944 #ifdef DEBUG
15945       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
15946 #endif
15947       do i=0,nct
15948         do j=1,3
15949           gcart(j,i)=gradc(j,i,icg)
15950           gxcart(j,i)=gradx(j,i,icg)
15951         enddo
15952 #ifdef DEBUG
15953         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
15954           (gxcart(j,i),j=1,3),gloc(i,icg)
15955 #endif
15956       enddo
15957 #ifdef TIMING
15958       time01=MPI_Wtime()
15959 #endif
15960       call int_to_cart
15961 #ifdef TIMING
15962       time_inttocart=time_inttocart+MPI_Wtime()-time01
15963 #endif
15964 #ifdef DEBUG
15965       write (iout,*) "gcart and gxcart after int_to_cart"
15966       do i=0,nres-1
15967         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
15968             (gxcart(j,i),j=1,3)
15969       enddo
15970 #endif
15971 #ifdef CARGRAD
15972 #ifdef DEBUG
15973       write (iout,*) "CARGRAD"
15974 #endif
15975       do i=nres,0,-1
15976         do j=1,3
15977           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
15978 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
15979         enddo
15980 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
15981 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
15982       enddo
15983 ! Correction: dummy residues
15984         if (nnt.gt.1) then
15985           do j=1,3
15986 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
15987             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
15988           enddo
15989         endif
15990         if (nct.lt.nres) then
15991           do j=1,3
15992 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
15993             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
15994           enddo
15995         endif
15996 #endif
15997 #ifdef TIMING
15998       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
15999 #endif
16000 !el#undef DEBUG
16001       return
16002       end subroutine cartgrad
16003 !-----------------------------------------------------------------------------
16004       subroutine zerograd
16005 !      implicit real*8 (a-h,o-z)
16006 !      include 'DIMENSIONS'
16007 !      include 'COMMON.DERIV'
16008 !      include 'COMMON.CHAIN'
16009 !      include 'COMMON.VAR'
16010 !      include 'COMMON.MD'
16011 !      include 'COMMON.SCCOR'
16012 !
16013 !el local variables
16014       integer :: i,j,intertyp,k
16015 ! Initialize Cartesian-coordinate gradient
16016 !
16017 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16018 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16019
16020 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16021 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16022 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16023 !      allocate(gradcorr_long(3,nres))
16024 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16025 !      allocate(gcorr6_turn_long(3,nres))
16026 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16027
16028 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16029
16030 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16031 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16032
16033 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16034 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16035
16036 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16037 !      allocate(gscloc(3,nres)) !(3,maxres)
16038 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16039
16040
16041
16042 !      common /deriv_scloc/
16043 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16044 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16045 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
16046 !      common /mpgrad/
16047 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16048
16049
16050
16051 !          gradc(j,i,icg)=0.0d0
16052 !          gradx(j,i,icg)=0.0d0
16053
16054 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16055 !elwrite(iout,*) "icg",icg
16056       do i=-1,nres
16057         do j=1,3
16058           gvdwx(j,i)=0.0D0
16059           gradx_scp(j,i)=0.0D0
16060           gvdwc(j,i)=0.0D0
16061           gvdwc_scp(j,i)=0.0D0
16062           gvdwc_scpp(j,i)=0.0d0
16063           gelc(j,i)=0.0D0
16064           gelc_long(j,i)=0.0D0
16065           gradb(j,i)=0.0d0
16066           gradbx(j,i)=0.0d0
16067           gvdwpp(j,i)=0.0d0
16068           gel_loc(j,i)=0.0d0
16069           gel_loc_long(j,i)=0.0d0
16070           ghpbc(j,i)=0.0D0
16071           ghpbx(j,i)=0.0D0
16072           gcorr3_turn(j,i)=0.0d0
16073           gcorr4_turn(j,i)=0.0d0
16074           gradcorr(j,i)=0.0d0
16075           gradcorr_long(j,i)=0.0d0
16076           gradcorr5_long(j,i)=0.0d0
16077           gradcorr6_long(j,i)=0.0d0
16078           gcorr6_turn_long(j,i)=0.0d0
16079           gradcorr5(j,i)=0.0d0
16080           gradcorr6(j,i)=0.0d0
16081           gcorr6_turn(j,i)=0.0d0
16082           gsccorc(j,i)=0.0d0
16083           gsccorx(j,i)=0.0d0
16084           gradc(j,i,icg)=0.0d0
16085           gradx(j,i,icg)=0.0d0
16086           gscloc(j,i)=0.0d0
16087           gsclocx(j,i)=0.0d0
16088           gliptran(j,i)=0.0d0
16089           gliptranx(j,i)=0.0d0
16090           gliptranc(j,i)=0.0d0
16091           gshieldx(j,i)=0.0d0
16092           gshieldc(j,i)=0.0d0
16093           gshieldc_loc(j,i)=0.0d0
16094           gshieldx_ec(j,i)=0.0d0
16095           gshieldc_ec(j,i)=0.0d0
16096           gshieldc_loc_ec(j,i)=0.0d0
16097           gshieldx_t3(j,i)=0.0d0
16098           gshieldc_t3(j,i)=0.0d0
16099           gshieldc_loc_t3(j,i)=0.0d0
16100           gshieldx_t4(j,i)=0.0d0
16101           gshieldc_t4(j,i)=0.0d0
16102           gshieldc_loc_t4(j,i)=0.0d0
16103           gshieldx_ll(j,i)=0.0d0
16104           gshieldc_ll(j,i)=0.0d0
16105           gshieldc_loc_ll(j,i)=0.0d0
16106           gg_tube(j,i)=0.0d0
16107           gg_tube_sc(j,i)=0.0d0
16108           gradafm(j,i)=0.0d0
16109           do intertyp=1,3
16110            gloc_sc(intertyp,i,icg)=0.0d0
16111           enddo
16112         enddo
16113       enddo
16114       do i=1,nres
16115        do j=1,maxcontsshi
16116        shield_list(j,i)=0
16117         do k=1,3
16118 !C           print *,i,j,k
16119            grad_shield_side(k,j,i)=0.0d0
16120            grad_shield_loc(k,j,i)=0.0d0
16121          enddo
16122        enddo
16123        ishield_list(i)=0
16124       enddo
16125
16126 !
16127 ! Initialize the gradient of local energy terms.
16128 !
16129 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
16130 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16131 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16132 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
16133 !      allocate(gel_loc_turn3(nres))
16134 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16135 !      allocate(gsccor_loc(nres))       !(maxres)
16136
16137       do i=1,4*nres
16138         gloc(i,icg)=0.0D0
16139       enddo
16140       do i=1,nres
16141         gel_loc_loc(i)=0.0d0
16142         gcorr_loc(i)=0.0d0
16143         g_corr5_loc(i)=0.0d0
16144         g_corr6_loc(i)=0.0d0
16145         gel_loc_turn3(i)=0.0d0
16146         gel_loc_turn4(i)=0.0d0
16147         gel_loc_turn6(i)=0.0d0
16148         gsccor_loc(i)=0.0d0
16149       enddo
16150 ! initialize gcart and gxcart
16151 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16152       do i=0,nres
16153         do j=1,3
16154           gcart(j,i)=0.0d0
16155           gxcart(j,i)=0.0d0
16156         enddo
16157       enddo
16158       return
16159       end subroutine zerograd
16160 !-----------------------------------------------------------------------------
16161       real(kind=8) function fdum()
16162       fdum=0.0D0
16163       return
16164       end function fdum
16165 !-----------------------------------------------------------------------------
16166 ! intcartderiv.F
16167 !-----------------------------------------------------------------------------
16168       subroutine intcartderiv
16169 !      implicit real*8 (a-h,o-z)
16170 !      include 'DIMENSIONS'
16171 #ifdef MPI
16172       include 'mpif.h'
16173 #endif
16174 !      include 'COMMON.SETUP'
16175 !      include 'COMMON.CHAIN'
16176 !      include 'COMMON.VAR'
16177 !      include 'COMMON.GEO'
16178 !      include 'COMMON.INTERACT'
16179 !      include 'COMMON.DERIV'
16180 !      include 'COMMON.IOUNITS'
16181 !      include 'COMMON.LOCAL'
16182 !      include 'COMMON.SCCOR'
16183       real(kind=8) :: pi4,pi34
16184       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16185       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16186                     dcosomega,dsinomega !(3,3,maxres)
16187       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16188
16189       integer :: i,j,k
16190       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16191                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16192                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16193                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16194       integer :: nres2
16195       nres2=2*nres
16196
16197 !el from module energy-------------
16198 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16199 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16200 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16201
16202 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16203 !el      allocate(dsintau(3,3,3,0:nres2))
16204 !el      allocate(dtauangle(3,3,3,0:nres2))
16205 !el      allocate(domicron(3,2,2,0:nres2))
16206 !el      allocate(dcosomicron(3,2,2,0:nres2))
16207
16208
16209
16210 #if defined(MPI) && defined(PARINTDER)
16211       if (nfgtasks.gt.1 .and. me.eq.king) &
16212         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16213 #endif
16214       pi4 = 0.5d0*pipol
16215       pi34 = 3*pi4
16216
16217 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
16218 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16219
16220 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16221       do i=1,nres
16222         do j=1,3
16223           dtheta(j,1,i)=0.0d0
16224           dtheta(j,2,i)=0.0d0
16225           dphi(j,1,i)=0.0d0
16226           dphi(j,2,i)=0.0d0
16227           dphi(j,3,i)=0.0d0
16228         enddo
16229       enddo
16230 ! Derivatives of theta's
16231 #if defined(MPI) && defined(PARINTDER)
16232 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16233       do i=max0(ithet_start-1,3),ithet_end
16234 #else
16235       do i=3,nres
16236 #endif
16237         cost=dcos(theta(i))
16238         sint=sqrt(1-cost*cost)
16239         do j=1,3
16240           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16241           vbld(i-1)
16242           if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16243           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16244           vbld(i)
16245           if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16246         enddo
16247       enddo
16248 #if defined(MPI) && defined(PARINTDER)
16249 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16250       do i=max0(ithet_start-1,3),ithet_end
16251 #else
16252       do i=3,nres
16253 #endif
16254       if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16255         cost1=dcos(omicron(1,i))
16256         sint1=sqrt(1-cost1*cost1)
16257         cost2=dcos(omicron(2,i))
16258         sint2=sqrt(1-cost2*cost2)
16259        do j=1,3
16260 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16261           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16262           cost1*dc_norm(j,i-2))/ &
16263           vbld(i-1)
16264           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16265           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16266           +cost1*(dc_norm(j,i-1+nres)))/ &
16267           vbld(i-1+nres)
16268           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16269 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16270 !C Looks messy but better than if in loop
16271           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16272           +cost2*dc_norm(j,i-1))/ &
16273           vbld(i)
16274           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16275           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16276            +cost2*(-dc_norm(j,i-1+nres)))/ &
16277           vbld(i-1+nres)
16278 !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16279           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16280         enddo
16281        endif
16282       enddo
16283 !elwrite(iout,*) "after vbld write"
16284 ! Derivatives of phi:
16285 ! If phi is 0 or 180 degrees, then the formulas
16286 ! have to be derived by power series expansion of the
16287 ! conventional formulas around 0 and 180.
16288 #ifdef PARINTDER
16289       do i=iphi1_start,iphi1_end
16290 #else
16291       do i=4,nres
16292 #endif
16293 !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16294 ! the conventional case
16295         sint=dsin(theta(i))
16296         sint1=dsin(theta(i-1))
16297         sing=dsin(phi(i))
16298         cost=dcos(theta(i))
16299         cost1=dcos(theta(i-1))
16300         cosg=dcos(phi(i))
16301         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16302         fac0=1.0d0/(sint1*sint)
16303         fac1=cost*fac0
16304         fac2=cost1*fac0
16305         fac3=cosg*cost1/(sint1*sint1)
16306         fac4=cosg*cost/(sint*sint)
16307 !    Obtaining the gamma derivatives from sine derivative
16308        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16309            phi(i).gt.pi34.and.phi(i).le.pi.or. &
16310            phi(i).ge.-pi.and.phi(i).le.-pi34) then
16311          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16312          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16313          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16314          do j=1,3
16315             ctgt=cost/sint
16316             ctgt1=cost1/sint1
16317             cosg_inv=1.0d0/cosg
16318             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16319             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16320               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16321             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16322             dsinphi(j,2,i)= &
16323               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16324               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16325             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16326             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16327               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16328 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16329             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16330             endif
16331 ! Bug fixed 3/24/05 (AL)
16332          enddo
16333 !   Obtaining the gamma derivatives from cosine derivative
16334         else
16335            do j=1,3
16336            if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16337            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16338            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16339            dc_norm(j,i-3))/vbld(i-2)
16340            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16341            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16342            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16343            dcostheta(j,1,i)
16344            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16345            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16346            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16347            dc_norm(j,i-1))/vbld(i)
16348            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16349            endif
16350          enddo
16351         endif
16352       enddo
16353 !alculate derivative of Tauangle
16354 #ifdef PARINTDER
16355       do i=itau_start,itau_end
16356 #else
16357       do i=3,nres
16358 !elwrite(iout,*) " vecpr",i,nres
16359 #endif
16360        if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16361 !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16362 !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16363 !c dtauangle(j,intertyp,dervityp,residue number)
16364 !c INTERTYP=1 SC...Ca...Ca..Ca
16365 ! the conventional case
16366         sint=dsin(theta(i))
16367         sint1=dsin(omicron(2,i-1))
16368         sing=dsin(tauangle(1,i))
16369         cost=dcos(theta(i))
16370         cost1=dcos(omicron(2,i-1))
16371         cosg=dcos(tauangle(1,i))
16372 !elwrite(iout,*) " vecpr5",i,nres
16373         do j=1,3
16374 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16375 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16376         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16377 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16378         enddo
16379         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16380         fac0=1.0d0/(sint1*sint)
16381         fac1=cost*fac0
16382         fac2=cost1*fac0
16383         fac3=cosg*cost1/(sint1*sint1)
16384         fac4=cosg*cost/(sint*sint)
16385 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16386 !    Obtaining the gamma derivatives from sine derivative
16387        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16388            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16389            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16390          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16391          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16392          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16393         do j=1,3
16394             ctgt=cost/sint
16395             ctgt1=cost1/sint1
16396             cosg_inv=1.0d0/cosg
16397             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16398        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16399        *vbld_inv(i-2+nres)
16400             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16401             dsintau(j,1,2,i)= &
16402               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16403               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16404 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16405             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16406 ! Bug fixed 3/24/05 (AL)
16407             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16408               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16409 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16410             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16411          enddo
16412 !   Obtaining the gamma derivatives from cosine derivative
16413         else
16414            do j=1,3
16415            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16416            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16417            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16418            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16419            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16420            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16421            dcostheta(j,1,i)
16422            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16423            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16424            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16425            dc_norm(j,i-1))/vbld(i)
16426            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16427 !         write (iout,*) "else",i
16428          enddo
16429         endif
16430 !        do k=1,3
16431 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16432 !        enddo
16433       enddo
16434 !C Second case Ca...Ca...Ca...SC
16435 #ifdef PARINTDER
16436       do i=itau_start,itau_end
16437 #else
16438       do i=4,nres
16439 #endif
16440        if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16441           (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16442 ! the conventional case
16443         sint=dsin(omicron(1,i))
16444         sint1=dsin(theta(i-1))
16445         sing=dsin(tauangle(2,i))
16446         cost=dcos(omicron(1,i))
16447         cost1=dcos(theta(i-1))
16448         cosg=dcos(tauangle(2,i))
16449 !        do j=1,3
16450 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16451 !        enddo
16452         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16453         fac0=1.0d0/(sint1*sint)
16454         fac1=cost*fac0
16455         fac2=cost1*fac0
16456         fac3=cosg*cost1/(sint1*sint1)
16457         fac4=cosg*cost/(sint*sint)
16458 !    Obtaining the gamma derivatives from sine derivative
16459        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16460            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16461            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16462          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16463          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16464          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16465         do j=1,3
16466             ctgt=cost/sint
16467             ctgt1=cost1/sint1
16468             cosg_inv=1.0d0/cosg
16469             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16470               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16471 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16472 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16473             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16474             dsintau(j,2,2,i)= &
16475               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16476               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16477 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16478 !     & sing*ctgt*domicron(j,1,2,i),
16479 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16480             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16481 ! Bug fixed 3/24/05 (AL)
16482             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16483              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16484 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16485             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16486          enddo
16487 !   Obtaining the gamma derivatives from cosine derivative
16488         else
16489            do j=1,3
16490            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16491            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16492            dc_norm(j,i-3))/vbld(i-2)
16493            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16494            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16495            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16496            dcosomicron(j,1,1,i)
16497            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16498            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16499            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16500            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16501            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16502 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16503          enddo
16504         endif
16505       enddo
16506
16507 !CC third case SC...Ca...Ca...SC
16508 #ifdef PARINTDER
16509
16510       do i=itau_start,itau_end
16511 #else
16512       do i=3,nres
16513 #endif
16514 ! the conventional case
16515       if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16516       (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16517         sint=dsin(omicron(1,i))
16518         sint1=dsin(omicron(2,i-1))
16519         sing=dsin(tauangle(3,i))
16520         cost=dcos(omicron(1,i))
16521         cost1=dcos(omicron(2,i-1))
16522         cosg=dcos(tauangle(3,i))
16523         do j=1,3
16524         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16525 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16526         enddo
16527         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16528         fac0=1.0d0/(sint1*sint)
16529         fac1=cost*fac0
16530         fac2=cost1*fac0
16531         fac3=cosg*cost1/(sint1*sint1)
16532         fac4=cosg*cost/(sint*sint)
16533 !    Obtaining the gamma derivatives from sine derivative
16534        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16535            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16536            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16537          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16538          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16539          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16540         do j=1,3
16541             ctgt=cost/sint
16542             ctgt1=cost1/sint1
16543             cosg_inv=1.0d0/cosg
16544             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16545               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16546               *vbld_inv(i-2+nres)
16547             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16548             dsintau(j,3,2,i)= &
16549               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16550               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16551             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16552 ! Bug fixed 3/24/05 (AL)
16553             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16554               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16555               *vbld_inv(i-1+nres)
16556 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16557             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16558          enddo
16559 !   Obtaining the gamma derivatives from cosine derivative
16560         else
16561            do j=1,3
16562            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16563            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16564            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16565            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16566            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16567            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16568            dcosomicron(j,1,1,i)
16569            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16570            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16571            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16572            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16573            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16574 !          write(iout,*) "else",i
16575          enddo
16576         endif
16577       enddo
16578
16579 #ifdef CRYST_SC
16580 !   Derivatives of side-chain angles alpha and omega
16581 #if defined(MPI) && defined(PARINTDER)
16582         do i=ibond_start,ibond_end
16583 #else
16584         do i=2,nres-1
16585 #endif
16586           if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16587              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16588              fac6=fac5/vbld(i)
16589              fac7=fac5*fac5
16590              fac8=fac5/vbld(i+1)
16591              fac9=fac5/vbld(i+nres)
16592              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16593              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16594              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16595              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16596              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16597              sina=sqrt(1-cosa*cosa)
16598              sino=dsin(omeg(i))
16599 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16600              do j=1,3
16601                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16602                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16603                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16604                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16605                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16606                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16607                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16608                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16609                 vbld(i+nres))
16610                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16611             enddo
16612 ! obtaining the derivatives of omega from sines
16613             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16614                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16615                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16616                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16617                dsin(theta(i+1)))
16618                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16619                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16620                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16621                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16622                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16623                coso_inv=1.0d0/dcos(omeg(i))
16624                do j=1,3
16625                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16626                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16627                  (sino*dc_norm(j,i-1))/vbld(i)
16628                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16629                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16630                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16631                  -sino*dc_norm(j,i)/vbld(i+1)
16632                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16633                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16634                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16635                  vbld(i+nres)
16636                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16637               enddo
16638            else
16639 !   obtaining the derivatives of omega from cosines
16640              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16641              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16642              fac12=fac10*sina
16643              fac13=fac12*fac12
16644              fac14=sina*sina
16645              do j=1,3
16646                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16647                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16648                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16649                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16650                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
16651                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
16652                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
16653                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
16654                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
16655                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
16656                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
16657                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
16658                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
16659                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
16660                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
16661             enddo
16662           endif
16663          else
16664            do j=1,3
16665              do k=1,3
16666                dalpha(k,j,i)=0.0d0
16667                domega(k,j,i)=0.0d0
16668              enddo
16669            enddo
16670          endif
16671        enddo
16672 #endif
16673 #if defined(MPI) && defined(PARINTDER)
16674       if (nfgtasks.gt.1) then
16675 #ifdef DEBUG
16676 !d      write (iout,*) "Gather dtheta"
16677 !d      call flush(iout)
16678       write (iout,*) "dtheta before gather"
16679       do i=1,nres
16680         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
16681       enddo
16682 #endif
16683       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
16684         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
16685         king,FG_COMM,IERROR)
16686 #ifdef DEBUG
16687 !d      write (iout,*) "Gather dphi"
16688 !d      call flush(iout)
16689       write (iout,*) "dphi before gather"
16690       do i=1,nres
16691         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
16692       enddo
16693 #endif
16694       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
16695         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
16696         king,FG_COMM,IERROR)
16697 !d      write (iout,*) "Gather dalpha"
16698 !d      call flush(iout)
16699 #ifdef CRYST_SC
16700       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
16701         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16702         king,FG_COMM,IERROR)
16703 !d      write (iout,*) "Gather domega"
16704 !d      call flush(iout)
16705       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
16706         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16707         king,FG_COMM,IERROR)
16708 #endif
16709       endif
16710 #endif
16711 #ifdef DEBUG
16712       write (iout,*) "dtheta after gather"
16713       do i=1,nres
16714         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
16715       enddo
16716       write (iout,*) "dphi after gather"
16717       do i=1,nres
16718         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
16719       enddo
16720       write (iout,*) "dalpha after gather"
16721       do i=1,nres
16722         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
16723       enddo
16724       write (iout,*) "domega after gather"
16725       do i=1,nres
16726         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
16727       enddo
16728 #endif
16729       return
16730       end subroutine intcartderiv
16731 !-----------------------------------------------------------------------------
16732       subroutine checkintcartgrad
16733 !      implicit real*8 (a-h,o-z)
16734 !      include 'DIMENSIONS'
16735 #ifdef MPI
16736       include 'mpif.h'
16737 #endif
16738 !      include 'COMMON.CHAIN'
16739 !      include 'COMMON.VAR'
16740 !      include 'COMMON.GEO'
16741 !      include 'COMMON.INTERACT'
16742 !      include 'COMMON.DERIV'
16743 !      include 'COMMON.IOUNITS'
16744 !      include 'COMMON.SETUP'
16745       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
16746       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
16747       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
16748       real(kind=8),dimension(3) :: dc_norm_s
16749       real(kind=8) :: aincr=1.0d-5
16750       integer :: i,j
16751       real(kind=8) :: dcji
16752       do i=1,nres
16753         phi_s(i)=phi(i)
16754         theta_s(i)=theta(i)
16755         alph_s(i)=alph(i)
16756         omeg_s(i)=omeg(i)
16757       enddo
16758 ! Check theta gradient
16759       write (iout,*) &
16760        "Analytical (upper) and numerical (lower) gradient of theta"
16761       write (iout,*)
16762       do i=3,nres
16763         do j=1,3
16764           dcji=dc(j,i-2)
16765           dc(j,i-2)=dcji+aincr
16766           call chainbuild_cart
16767           call int_from_cart1(.false.)
16768           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
16769           dc(j,i-2)=dcji
16770           dcji=dc(j,i-1)
16771           dc(j,i-1)=dc(j,i-1)+aincr
16772           call chainbuild_cart
16773           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
16774           dc(j,i-1)=dcji
16775         enddo
16776 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
16777 !el          (dtheta(j,2,i),j=1,3)
16778 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
16779 !el          (dthetanum(j,2,i),j=1,3)
16780 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
16781 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
16782 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
16783 !el        write (iout,*)
16784       enddo
16785 ! Check gamma gradient
16786       write (iout,*) &
16787        "Analytical (upper) and numerical (lower) gradient of gamma"
16788       do i=4,nres
16789         do j=1,3
16790           dcji=dc(j,i-3)
16791           dc(j,i-3)=dcji+aincr
16792           call chainbuild_cart
16793           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
16794           dc(j,i-3)=dcji
16795           dcji=dc(j,i-2)
16796           dc(j,i-2)=dcji+aincr
16797           call chainbuild_cart
16798           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
16799           dc(j,i-2)=dcji
16800           dcji=dc(j,i-1)
16801           dc(j,i-1)=dc(j,i-1)+aincr
16802           call chainbuild_cart
16803           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
16804           dc(j,i-1)=dcji
16805         enddo
16806 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
16807 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
16808 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
16809 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
16810 !el        write (iout,'(5x,3(3f10.5,5x))') &
16811 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
16812 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
16813 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
16814 !el        write (iout,*)
16815       enddo
16816 ! Check alpha gradient
16817       write (iout,*) &
16818        "Analytical (upper) and numerical (lower) gradient of alpha"
16819       do i=2,nres-1
16820        if(itype(i,1).ne.10) then
16821             do j=1,3
16822               dcji=dc(j,i-1)
16823               dc(j,i-1)=dcji+aincr
16824               call chainbuild_cart
16825               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
16826               /aincr
16827               dc(j,i-1)=dcji
16828               dcji=dc(j,i)
16829               dc(j,i)=dcji+aincr
16830               call chainbuild_cart
16831               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
16832               /aincr
16833               dc(j,i)=dcji
16834               dcji=dc(j,i+nres)
16835               dc(j,i+nres)=dc(j,i+nres)+aincr
16836               call chainbuild_cart
16837               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
16838               /aincr
16839              dc(j,i+nres)=dcji
16840             enddo
16841           endif
16842 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
16843 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
16844 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
16845 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
16846 !el        write (iout,'(5x,3(3f10.5,5x))') &
16847 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
16848 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
16849 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
16850 !el        write (iout,*)
16851       enddo
16852 !     Check omega gradient
16853       write (iout,*) &
16854        "Analytical (upper) and numerical (lower) gradient of omega"
16855       do i=2,nres-1
16856        if(itype(i,1).ne.10) then
16857             do j=1,3
16858               dcji=dc(j,i-1)
16859               dc(j,i-1)=dcji+aincr
16860               call chainbuild_cart
16861               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
16862               /aincr
16863               dc(j,i-1)=dcji
16864               dcji=dc(j,i)
16865               dc(j,i)=dcji+aincr
16866               call chainbuild_cart
16867               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
16868               /aincr
16869               dc(j,i)=dcji
16870               dcji=dc(j,i+nres)
16871               dc(j,i+nres)=dc(j,i+nres)+aincr
16872               call chainbuild_cart
16873               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
16874               /aincr
16875              dc(j,i+nres)=dcji
16876             enddo
16877           endif
16878 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
16879 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
16880 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
16881 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
16882 !el        write (iout,'(5x,3(3f10.5,5x))') &
16883 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
16884 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
16885 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
16886 !el        write (iout,*)
16887       enddo
16888       return
16889       end subroutine checkintcartgrad
16890 !-----------------------------------------------------------------------------
16891 ! q_measure.F
16892 !-----------------------------------------------------------------------------
16893       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
16894 !      implicit real*8 (a-h,o-z)
16895 !      include 'DIMENSIONS'
16896 !      include 'COMMON.IOUNITS'
16897 !      include 'COMMON.CHAIN'
16898 !      include 'COMMON.INTERACT'
16899 !      include 'COMMON.VAR'
16900       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
16901       integer :: kkk,nsep=3
16902       real(kind=8) :: qm        !dist,
16903       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
16904       logical :: lprn=.false.
16905       logical :: flag
16906 !      real(kind=8) :: sigm,x
16907
16908 !el      sigm(x)=0.25d0*x     ! local function
16909       qqmax=1.0d10
16910       do kkk=1,nperm
16911       qq = 0.0d0
16912       nl=0
16913        if(flag) then
16914         do il=seg1+nsep,seg2
16915           do jl=seg1,il-nsep
16916             nl=nl+1
16917             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
16918                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
16919                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16920             dij=dist(il,jl)
16921             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
16922             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
16923               nl=nl+1
16924               d0ijCM=dsqrt( &
16925                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16926                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16927                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16928               dijCM=dist(il+nres,jl+nres)
16929               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
16930             endif
16931             qq = qq+qqij+qqijCM
16932           enddo
16933         enddo
16934         qq = qq/nl
16935       else
16936       do il=seg1,seg2
16937         if((seg3-il).lt.3) then
16938              secseg=il+3
16939         else
16940              secseg=seg3
16941         endif
16942           do jl=secseg,seg4
16943             nl=nl+1
16944             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16945                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16946                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16947             dij=dist(il,jl)
16948             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
16949             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
16950               nl=nl+1
16951               d0ijCM=dsqrt( &
16952                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16953                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16954                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16955               dijCM=dist(il+nres,jl+nres)
16956               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
16957             endif
16958             qq = qq+qqij+qqijCM
16959           enddo
16960         enddo
16961       qq = qq/nl
16962       endif
16963       if (qqmax.le.qq) qqmax=qq
16964       enddo
16965       qwolynes=1.0d0-qqmax
16966       return
16967       end function qwolynes
16968 !-----------------------------------------------------------------------------
16969       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
16970 !      implicit real*8 (a-h,o-z)
16971 !      include 'DIMENSIONS'
16972 !      include 'COMMON.IOUNITS'
16973 !      include 'COMMON.CHAIN'
16974 !      include 'COMMON.INTERACT'
16975 !      include 'COMMON.VAR'
16976 !      include 'COMMON.MD'
16977       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
16978       integer :: nsep=3, kkk
16979 !el      real(kind=8) :: dist
16980       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
16981       logical :: lprn=.false.
16982       logical :: flag
16983       real(kind=8) :: sim,dd0,fac,ddqij
16984 !el      sigm(x)=0.25d0*x            ! local function
16985       do kkk=1,nperm
16986       do i=0,nres
16987         do j=1,3
16988           dqwol(j,i)=0.0d0
16989           dxqwol(j,i)=0.0d0
16990         enddo
16991       enddo
16992       nl=0
16993        if(flag) then
16994         do il=seg1+nsep,seg2
16995           do jl=seg1,il-nsep
16996             nl=nl+1
16997             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16998                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16999                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17000             dij=dist(il,jl)
17001             sim = 1.0d0/sigm(d0ij)
17002             sim = sim*sim
17003             dd0 = dij-d0ij
17004             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17005             do k=1,3
17006               ddqij = (c(k,il)-c(k,jl))*fac
17007               dqwol(k,il)=dqwol(k,il)+ddqij
17008               dqwol(k,jl)=dqwol(k,jl)-ddqij
17009             enddo
17010
17011             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17012               nl=nl+1
17013               d0ijCM=dsqrt( &
17014                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17015                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17016                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17017               dijCM=dist(il+nres,jl+nres)
17018               sim = 1.0d0/sigm(d0ijCM)
17019               sim = sim*sim
17020               dd0=dijCM-d0ijCM
17021               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17022               do k=1,3
17023                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17024                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17025                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17026               enddo
17027             endif
17028           enddo
17029         enddo
17030        else
17031         do il=seg1,seg2
17032         if((seg3-il).lt.3) then
17033              secseg=il+3
17034         else
17035              secseg=seg3
17036         endif
17037           do jl=secseg,seg4
17038             nl=nl+1
17039             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17040                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17041                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17042             dij=dist(il,jl)
17043             sim = 1.0d0/sigm(d0ij)
17044             sim = sim*sim
17045             dd0 = dij-d0ij
17046             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17047             do k=1,3
17048               ddqij = (c(k,il)-c(k,jl))*fac
17049               dqwol(k,il)=dqwol(k,il)+ddqij
17050               dqwol(k,jl)=dqwol(k,jl)-ddqij
17051             enddo
17052             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17053               nl=nl+1
17054               d0ijCM=dsqrt( &
17055                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17056                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17057                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17058               dijCM=dist(il+nres,jl+nres)
17059               sim = 1.0d0/sigm(d0ijCM)
17060               sim=sim*sim
17061               dd0 = dijCM-d0ijCM
17062               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17063               do k=1,3
17064                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17065                dxqwol(k,il)=dxqwol(k,il)+ddqij
17066                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17067               enddo
17068             endif
17069           enddo
17070         enddo
17071       endif
17072       enddo
17073        do i=0,nres
17074          do j=1,3
17075            dqwol(j,i)=dqwol(j,i)/nl
17076            dxqwol(j,i)=dxqwol(j,i)/nl
17077          enddo
17078        enddo
17079       return
17080       end subroutine qwolynes_prim
17081 !-----------------------------------------------------------------------------
17082       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17083 !      implicit real*8 (a-h,o-z)
17084 !      include 'DIMENSIONS'
17085 !      include 'COMMON.IOUNITS'
17086 !      include 'COMMON.CHAIN'
17087 !      include 'COMMON.INTERACT'
17088 !      include 'COMMON.VAR'
17089       integer :: seg1,seg2,seg3,seg4
17090       logical :: flag
17091       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17092       real(kind=8),dimension(3,0:2*nres) :: cdummy
17093       real(kind=8) :: q1,q2
17094       real(kind=8) :: delta=1.0d-10
17095       integer :: i,j
17096
17097       do i=0,nres
17098         do j=1,3
17099           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17100           cdummy(j,i)=c(j,i)
17101           c(j,i)=c(j,i)+delta
17102           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17103           qwolan(j,i)=(q2-q1)/delta
17104           c(j,i)=cdummy(j,i)
17105         enddo
17106       enddo
17107       do i=0,nres
17108         do j=1,3
17109           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17110           cdummy(j,i+nres)=c(j,i+nres)
17111           c(j,i+nres)=c(j,i+nres)+delta
17112           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17113           qwolxan(j,i)=(q2-q1)/delta
17114           c(j,i+nres)=cdummy(j,i+nres)
17115         enddo
17116       enddo
17117 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17118 !      do i=0,nct
17119 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17120 !      enddo
17121 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17122 !      do i=0,nct
17123 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17124 !      enddo
17125       return
17126       end subroutine qwol_num
17127 !-----------------------------------------------------------------------------
17128       subroutine EconstrQ
17129 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17130 !      implicit real*8 (a-h,o-z)
17131 !      include 'DIMENSIONS'
17132 !      include 'COMMON.CONTROL'
17133 !      include 'COMMON.VAR'
17134 !      include 'COMMON.MD'
17135       use MD_data
17136 !#ifndef LANG0
17137 !      include 'COMMON.LANGEVIN'
17138 !#else
17139 !      include 'COMMON.LANGEVIN.lang0'
17140 !#endif
17141 !      include 'COMMON.CHAIN'
17142 !      include 'COMMON.DERIV'
17143 !      include 'COMMON.GEO'
17144 !      include 'COMMON.LOCAL'
17145 !      include 'COMMON.INTERACT'
17146 !      include 'COMMON.IOUNITS'
17147 !      include 'COMMON.NAMES'
17148 !      include 'COMMON.TIME1'
17149       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17150       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17151                    duconst,duxconst
17152       integer :: kstart,kend,lstart,lend,idummy
17153       real(kind=8) :: delta=1.0d-7
17154       integer :: i,j,k,ii
17155       do i=0,nres
17156          do j=1,3
17157             duconst(j,i)=0.0d0
17158             dudconst(j,i)=0.0d0
17159             duxconst(j,i)=0.0d0
17160             dudxconst(j,i)=0.0d0
17161          enddo
17162       enddo
17163       Uconst=0.0d0
17164       do i=1,nfrag
17165          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17166            idummy,idummy)
17167          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17168 ! Calculating the derivatives of Constraint energy with respect to Q
17169          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17170            qinfrag(i,iset))
17171 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17172 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17173 !         hmnum=(hm2-hm1)/delta
17174 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17175 !     &   qinfrag(i,iset))
17176 !         write(iout,*) "harmonicnum frag", hmnum
17177 ! Calculating the derivatives of Q with respect to cartesian coordinates
17178          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17179           idummy,idummy)
17180 !         write(iout,*) "dqwol "
17181 !         do ii=1,nres
17182 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17183 !         enddo
17184 !         write(iout,*) "dxqwol "
17185 !         do ii=1,nres
17186 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17187 !         enddo
17188 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17189 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17190 !     &  ,idummy,idummy)
17191 !  The gradients of Uconst in Cs
17192          do ii=0,nres
17193             do j=1,3
17194                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17195                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17196             enddo
17197          enddo
17198       enddo
17199       do i=1,npair
17200          kstart=ifrag(1,ipair(1,i,iset),iset)
17201          kend=ifrag(2,ipair(1,i,iset),iset)
17202          lstart=ifrag(1,ipair(2,i,iset),iset)
17203          lend=ifrag(2,ipair(2,i,iset),iset)
17204          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17205          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17206 !  Calculating dU/dQ
17207          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17208 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17209 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17210 !         hmnum=(hm2-hm1)/delta
17211 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17212 !     &   qinpair(i,iset))
17213 !         write(iout,*) "harmonicnum pair ", hmnum
17214 ! Calculating dQ/dXi
17215          call qwolynes_prim(kstart,kend,.false.,&
17216           lstart,lend)
17217 !         write(iout,*) "dqwol "
17218 !         do ii=1,nres
17219 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17220 !         enddo
17221 !         write(iout,*) "dxqwol "
17222 !         do ii=1,nres
17223 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17224 !        enddo
17225 ! Calculating numerical gradients
17226 !        call qwol_num(kstart,kend,.false.
17227 !     &  ,lstart,lend)
17228 ! The gradients of Uconst in Cs
17229          do ii=0,nres
17230             do j=1,3
17231                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17232                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17233             enddo
17234          enddo
17235       enddo
17236 !      write(iout,*) "Uconst inside subroutine ", Uconst
17237 ! Transforming the gradients from Cs to dCs for the backbone
17238       do i=0,nres
17239          do j=i+1,nres
17240            do k=1,3
17241              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17242            enddo
17243          enddo
17244       enddo
17245 !  Transforming the gradients from Cs to dCs for the side chains
17246       do i=1,nres
17247          do j=1,3
17248            dudxconst(j,i)=duxconst(j,i)
17249          enddo
17250       enddo
17251 !      write(iout,*) "dU/ddc backbone "
17252 !       do ii=0,nres
17253 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17254 !      enddo
17255 !      write(iout,*) "dU/ddX side chain "
17256 !      do ii=1,nres
17257 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17258 !      enddo
17259 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17260 !      call dEconstrQ_num
17261       return
17262       end subroutine EconstrQ
17263 !-----------------------------------------------------------------------------
17264       subroutine dEconstrQ_num
17265 ! Calculating numerical dUconst/ddc and dUconst/ddx
17266 !      implicit real*8 (a-h,o-z)
17267 !      include 'DIMENSIONS'
17268 !      include 'COMMON.CONTROL'
17269 !      include 'COMMON.VAR'
17270 !      include 'COMMON.MD'
17271       use MD_data
17272 !#ifndef LANG0
17273 !      include 'COMMON.LANGEVIN'
17274 !#else
17275 !      include 'COMMON.LANGEVIN.lang0'
17276 !#endif
17277 !      include 'COMMON.CHAIN'
17278 !      include 'COMMON.DERIV'
17279 !      include 'COMMON.GEO'
17280 !      include 'COMMON.LOCAL'
17281 !      include 'COMMON.INTERACT'
17282 !      include 'COMMON.IOUNITS'
17283 !      include 'COMMON.NAMES'
17284 !      include 'COMMON.TIME1'
17285       real(kind=8) :: uzap1,uzap2
17286       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17287       integer :: kstart,kend,lstart,lend,idummy
17288       real(kind=8) :: delta=1.0d-7
17289 !el local variables
17290       integer :: i,ii,j
17291 !     real(kind=8) ::
17292 !     For the backbone
17293       do i=0,nres-1
17294          do j=1,3
17295             dUcartan(j,i)=0.0d0
17296             cdummy(j,i)=dc(j,i)
17297             dc(j,i)=dc(j,i)+delta
17298             call chainbuild_cart
17299             uzap2=0.0d0
17300             do ii=1,nfrag
17301              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17302                 idummy,idummy)
17303                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17304                 qinfrag(ii,iset))
17305             enddo
17306             do ii=1,npair
17307                kstart=ifrag(1,ipair(1,ii,iset),iset)
17308                kend=ifrag(2,ipair(1,ii,iset),iset)
17309                lstart=ifrag(1,ipair(2,ii,iset),iset)
17310                lend=ifrag(2,ipair(2,ii,iset),iset)
17311                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17312                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17313                  qinpair(ii,iset))
17314             enddo
17315             dc(j,i)=cdummy(j,i)
17316             call chainbuild_cart
17317             uzap1=0.0d0
17318              do ii=1,nfrag
17319              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17320                 idummy,idummy)
17321                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17322                 qinfrag(ii,iset))
17323             enddo
17324             do ii=1,npair
17325                kstart=ifrag(1,ipair(1,ii,iset),iset)
17326                kend=ifrag(2,ipair(1,ii,iset),iset)
17327                lstart=ifrag(1,ipair(2,ii,iset),iset)
17328                lend=ifrag(2,ipair(2,ii,iset),iset)
17329                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17330                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17331                 qinpair(ii,iset))
17332             enddo
17333             ducartan(j,i)=(uzap2-uzap1)/(delta)
17334          enddo
17335       enddo
17336 ! Calculating numerical gradients for dU/ddx
17337       do i=0,nres-1
17338          duxcartan(j,i)=0.0d0
17339          do j=1,3
17340             cdummy(j,i)=dc(j,i+nres)
17341             dc(j,i+nres)=dc(j,i+nres)+delta
17342             call chainbuild_cart
17343             uzap2=0.0d0
17344             do ii=1,nfrag
17345              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17346                 idummy,idummy)
17347                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17348                 qinfrag(ii,iset))
17349             enddo
17350             do ii=1,npair
17351                kstart=ifrag(1,ipair(1,ii,iset),iset)
17352                kend=ifrag(2,ipair(1,ii,iset),iset)
17353                lstart=ifrag(1,ipair(2,ii,iset),iset)
17354                lend=ifrag(2,ipair(2,ii,iset),iset)
17355                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17356                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17357                 qinpair(ii,iset))
17358             enddo
17359             dc(j,i+nres)=cdummy(j,i)
17360             call chainbuild_cart
17361             uzap1=0.0d0
17362              do ii=1,nfrag
17363                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17364                 ifrag(2,ii,iset),.true.,idummy,idummy)
17365                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17366                 qinfrag(ii,iset))
17367             enddo
17368             do ii=1,npair
17369                kstart=ifrag(1,ipair(1,ii,iset),iset)
17370                kend=ifrag(2,ipair(1,ii,iset),iset)
17371                lstart=ifrag(1,ipair(2,ii,iset),iset)
17372                lend=ifrag(2,ipair(2,ii,iset),iset)
17373                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17374                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17375                 qinpair(ii,iset))
17376             enddo
17377             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17378          enddo
17379       enddo
17380       write(iout,*) "Numerical dUconst/ddc backbone "
17381       do ii=0,nres
17382         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17383       enddo
17384 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17385 !      do ii=1,nres
17386 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17387 !      enddo
17388       return
17389       end subroutine dEconstrQ_num
17390 !-----------------------------------------------------------------------------
17391 ! ssMD.F
17392 !-----------------------------------------------------------------------------
17393       subroutine check_energies
17394
17395 !      use random, only: ran_number
17396
17397 !      implicit none
17398 !     Includes
17399 !      include 'DIMENSIONS'
17400 !      include 'COMMON.CHAIN'
17401 !      include 'COMMON.VAR'
17402 !      include 'COMMON.IOUNITS'
17403 !      include 'COMMON.SBRIDGE'
17404 !      include 'COMMON.LOCAL'
17405 !      include 'COMMON.GEO'
17406
17407 !     External functions
17408 !EL      double precision ran_number
17409 !EL      external ran_number
17410
17411 !     Local variables
17412       integer :: i,j,k,l,lmax,p,pmax
17413       real(kind=8) :: rmin,rmax
17414       real(kind=8) :: eij
17415
17416       real(kind=8) :: d
17417       real(kind=8) :: wi,rij,tj,pj
17418 !      return
17419
17420       i=5
17421       j=14
17422
17423       d=dsc(1)
17424       rmin=2.0D0
17425       rmax=12.0D0
17426
17427       lmax=10000
17428       pmax=1
17429
17430       do k=1,3
17431         c(k,i)=0.0D0
17432         c(k,j)=0.0D0
17433         c(k,nres+i)=0.0D0
17434         c(k,nres+j)=0.0D0
17435       enddo
17436
17437       do l=1,lmax
17438
17439 !t        wi=ran_number(0.0D0,pi)
17440 !        wi=ran_number(0.0D0,pi/6.0D0)
17441 !        wi=0.0D0
17442 !t        tj=ran_number(0.0D0,pi)
17443 !t        pj=ran_number(0.0D0,pi)
17444 !        pj=ran_number(0.0D0,pi/6.0D0)
17445 !        pj=0.0D0
17446
17447         do p=1,pmax
17448 !t           rij=ran_number(rmin,rmax)
17449
17450            c(1,j)=d*sin(pj)*cos(tj)
17451            c(2,j)=d*sin(pj)*sin(tj)
17452            c(3,j)=d*cos(pj)
17453
17454            c(3,nres+i)=-rij
17455
17456            c(1,i)=d*sin(wi)
17457            c(3,i)=-rij-d*cos(wi)
17458
17459            do k=1,3
17460               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17461               dc_norm(k,nres+i)=dc(k,nres+i)/d
17462               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17463               dc_norm(k,nres+j)=dc(k,nres+j)/d
17464            enddo
17465
17466            call dyn_ssbond_ene(i,j,eij)
17467         enddo
17468       enddo
17469       call exit(1)
17470       return
17471       end subroutine check_energies
17472 !-----------------------------------------------------------------------------
17473       subroutine dyn_ssbond_ene(resi,resj,eij)
17474 !      implicit none
17475 !      Includes
17476       use calc_data
17477       use comm_sschecks
17478 !      include 'DIMENSIONS'
17479 !      include 'COMMON.SBRIDGE'
17480 !      include 'COMMON.CHAIN'
17481 !      include 'COMMON.DERIV'
17482 !      include 'COMMON.LOCAL'
17483 !      include 'COMMON.INTERACT'
17484 !      include 'COMMON.VAR'
17485 !      include 'COMMON.IOUNITS'
17486 !      include 'COMMON.CALC'
17487 #ifndef CLUST
17488 #ifndef WHAM
17489        use MD_data
17490 !      include 'COMMON.MD'
17491 !      use MD, only: totT,t_bath
17492 #endif
17493 #endif
17494 !     External functions
17495 !EL      double precision h_base
17496 !EL      external h_base
17497
17498 !     Input arguments
17499       integer :: resi,resj
17500
17501 !     Output arguments
17502       real(kind=8) :: eij
17503
17504 !     Local variables
17505       logical :: havebond
17506       integer itypi,itypj
17507       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17508       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17509       real(kind=8),dimension(3) :: dcosom1,dcosom2
17510       real(kind=8) :: ed
17511       real(kind=8) :: pom1,pom2
17512       real(kind=8) :: ljA,ljB,ljXs
17513       real(kind=8),dimension(1:3) :: d_ljB
17514       real(kind=8) :: ssA,ssB,ssC,ssXs
17515       real(kind=8) :: ssxm,ljxm,ssm,ljm
17516       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17517       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17518       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17519 !-------FIRST METHOD
17520       real(kind=8) :: xm
17521       real(kind=8),dimension(1:3) :: d_xm
17522 !-------END FIRST METHOD
17523 !-------SECOND METHOD
17524 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17525 !-------END SECOND METHOD
17526
17527 !-------TESTING CODE
17528 !el      logical :: checkstop,transgrad
17529 !el      common /sschecks/ checkstop,transgrad
17530
17531       integer :: icheck,nicheck,jcheck,njcheck
17532       real(kind=8),dimension(-1:1) :: echeck
17533       real(kind=8) :: deps,ssx0,ljx0
17534 !-------END TESTING CODE
17535
17536       eij=0.0d0
17537       i=resi
17538       j=resj
17539
17540 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17541 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17542
17543       itypi=itype(i,1)
17544       dxi=dc_norm(1,nres+i)
17545       dyi=dc_norm(2,nres+i)
17546       dzi=dc_norm(3,nres+i)
17547       dsci_inv=vbld_inv(i+nres)
17548
17549       itypj=itype(j,1)
17550       xj=c(1,nres+j)-c(1,nres+i)
17551       yj=c(2,nres+j)-c(2,nres+i)
17552       zj=c(3,nres+j)-c(3,nres+i)
17553       dxj=dc_norm(1,nres+j)
17554       dyj=dc_norm(2,nres+j)
17555       dzj=dc_norm(3,nres+j)
17556       dscj_inv=vbld_inv(j+nres)
17557
17558       chi1=chi(itypi,itypj)
17559       chi2=chi(itypj,itypi)
17560       chi12=chi1*chi2
17561       chip1=chip(itypi)
17562       chip2=chip(itypj)
17563       chip12=chip1*chip2
17564       alf1=alp(itypi)
17565       alf2=alp(itypj)
17566       alf12=0.5D0*(alf1+alf2)
17567
17568       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17569       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17570 !     The following are set in sc_angular
17571 !      erij(1)=xj*rij
17572 !      erij(2)=yj*rij
17573 !      erij(3)=zj*rij
17574 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17575 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17576 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17577       call sc_angular
17578       rij=1.0D0/rij  ! Reset this so it makes sense
17579
17580       sig0ij=sigma(itypi,itypj)
17581       sig=sig0ij*dsqrt(1.0D0/sigsq)
17582
17583       ljXs=sig-sig0ij
17584       ljA=eps1*eps2rt**2*eps3rt**2
17585       ljB=ljA*bb_aq(itypi,itypj)
17586       ljA=ljA*aa_aq(itypi,itypj)
17587       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17588
17589       ssXs=d0cm
17590       deltat1=1.0d0-om1
17591       deltat2=1.0d0+om2
17592       deltat12=om2-om1+2.0d0
17593       cosphi=om12-om1*om2
17594       ssA=akcm
17595       ssB=akct*deltat12
17596       ssC=ss_depth &
17597            +akth*(deltat1*deltat1+deltat2*deltat2) &
17598            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17599       ssxm=ssXs-0.5D0*ssB/ssA
17600
17601 !-------TESTING CODE
17602 !$$$c     Some extra output
17603 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17604 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17605 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17606 !$$$      if (ssx0.gt.0.0d0) then
17607 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17608 !$$$      else
17609 !$$$        ssx0=ssxm
17610 !$$$      endif
17611 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17612 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17613 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17614 !$$$      return
17615 !-------END TESTING CODE
17616
17617 !-------TESTING CODE
17618 !     Stop and plot energy and derivative as a function of distance
17619       if (checkstop) then
17620         ssm=ssC-0.25D0*ssB*ssB/ssA
17621         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17622         if (ssm.lt.ljm .and. &
17623              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17624           nicheck=1000
17625           njcheck=1
17626           deps=0.5d-7
17627         else
17628           checkstop=.false.
17629         endif
17630       endif
17631       if (.not.checkstop) then
17632         nicheck=0
17633         njcheck=-1
17634       endif
17635
17636       do icheck=0,nicheck
17637       do jcheck=-1,njcheck
17638       if (checkstop) rij=(ssxm-1.0d0)+ &
17639              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17640 !-------END TESTING CODE
17641
17642       if (rij.gt.ljxm) then
17643         havebond=.false.
17644         ljd=rij-ljXs
17645         fac=(1.0D0/ljd)**expon
17646         e1=fac*fac*aa_aq(itypi,itypj)
17647         e2=fac*bb_aq(itypi,itypj)
17648         eij=eps1*eps2rt*eps3rt*(e1+e2)
17649         eps2der=eij*eps3rt
17650         eps3der=eij*eps2rt
17651         eij=eij*eps2rt*eps3rt
17652
17653         sigder=-sig/sigsq
17654         e1=e1*eps1*eps2rt**2*eps3rt**2
17655         ed=-expon*(e1+eij)/ljd
17656         sigder=ed*sigder
17657         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17658         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17659         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
17660              -2.0D0*alf12*eps3der+sigder*sigsq_om12
17661       else if (rij.lt.ssxm) then
17662         havebond=.true.
17663         ssd=rij-ssXs
17664         eij=ssA*ssd*ssd+ssB*ssd+ssC
17665
17666         ed=2*akcm*ssd+akct*deltat12
17667         pom1=akct*ssd
17668         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
17669         eom1=-2*akth*deltat1-pom1-om2*pom2
17670         eom2= 2*akth*deltat2+pom1-om1*pom2
17671         eom12=pom2
17672       else
17673         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
17674
17675         d_ssxm(1)=0.5D0*akct/ssA
17676         d_ssxm(2)=-d_ssxm(1)
17677         d_ssxm(3)=0.0D0
17678
17679         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
17680         d_ljxm(2)=d_ljxm(1)*sigsq_om2
17681         d_ljxm(3)=d_ljxm(1)*sigsq_om12
17682         d_ljxm(1)=d_ljxm(1)*sigsq_om1
17683
17684 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17685         xm=0.5d0*(ssxm+ljxm)
17686         do k=1,3
17687           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
17688         enddo
17689         if (rij.lt.xm) then
17690           havebond=.true.
17691           ssm=ssC-0.25D0*ssB*ssB/ssA
17692           d_ssm(1)=0.5D0*akct*ssB/ssA
17693           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17694           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17695           d_ssm(3)=omega
17696           f1=(rij-xm)/(ssxm-xm)
17697           f2=(rij-ssxm)/(xm-ssxm)
17698           h1=h_base(f1,hd1)
17699           h2=h_base(f2,hd2)
17700           eij=ssm*h1+Ht*h2
17701           delta_inv=1.0d0/(xm-ssxm)
17702           deltasq_inv=delta_inv*delta_inv
17703           fac=ssm*hd1-Ht*hd2
17704           fac1=deltasq_inv*fac*(xm-rij)
17705           fac2=deltasq_inv*fac*(rij-ssxm)
17706           ed=delta_inv*(Ht*hd2-ssm*hd1)
17707           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
17708           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
17709           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
17710         else
17711           havebond=.false.
17712           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17713           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
17714           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
17715           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
17716                alf12/eps3rt)
17717           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
17718           f1=(rij-ljxm)/(xm-ljxm)
17719           f2=(rij-xm)/(ljxm-xm)
17720           h1=h_base(f1,hd1)
17721           h2=h_base(f2,hd2)
17722           eij=Ht*h1+ljm*h2
17723           delta_inv=1.0d0/(ljxm-xm)
17724           deltasq_inv=delta_inv*delta_inv
17725           fac=Ht*hd1-ljm*hd2
17726           fac1=deltasq_inv*fac*(ljxm-rij)
17727           fac2=deltasq_inv*fac*(rij-xm)
17728           ed=delta_inv*(ljm*hd2-Ht*hd1)
17729           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
17730           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
17731           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
17732         endif
17733 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17734
17735 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17736 !$$$        ssd=rij-ssXs
17737 !$$$        ljd=rij-ljXs
17738 !$$$        fac1=rij-ljxm
17739 !$$$        fac2=rij-ssxm
17740 !$$$
17741 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
17742 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
17743 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
17744 !$$$
17745 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
17746 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
17747 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17748 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17749 !$$$        d_ssm(3)=omega
17750 !$$$
17751 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
17752 !$$$        do k=1,3
17753 !$$$          d_ljm(k)=ljm*d_ljB(k)
17754 !$$$        enddo
17755 !$$$        ljm=ljm*ljB
17756 !$$$
17757 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
17758 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
17759 !$$$        d_ss(2)=akct*ssd
17760 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
17761 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
17762 !$$$        d_ss(3)=omega
17763 !$$$
17764 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
17765 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
17766 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
17767 !$$$        do k=1,3
17768 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
17769 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
17770 !$$$        enddo
17771 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
17772 !$$$
17773 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
17774 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
17775 !$$$        h1=h_base(f1,hd1)
17776 !$$$        h2=h_base(f2,hd2)
17777 !$$$        eij=ss*h1+ljf*h2
17778 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
17779 !$$$        deltasq_inv=delta_inv*delta_inv
17780 !$$$        fac=ljf*hd2-ss*hd1
17781 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
17782 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
17783 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
17784 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
17785 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
17786 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
17787 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
17788 !$$$
17789 !$$$        havebond=.false.
17790 !$$$        if (ed.gt.0.0d0) havebond=.true.
17791 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17792
17793       endif
17794
17795       if (havebond) then
17796 !#ifndef CLUST
17797 !#ifndef WHAM
17798 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
17799 !          write(iout,'(a15,f12.2,f8.1,2i5)')
17800 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
17801 !        endif
17802 !#endif
17803 !#endif
17804         dyn_ssbond_ij(i,j)=eij
17805       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
17806         dyn_ssbond_ij(i,j)=1.0d300
17807 !#ifndef CLUST
17808 !#ifndef WHAM
17809 !        write(iout,'(a15,f12.2,f8.1,2i5)')
17810 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
17811 !#endif
17812 !#endif
17813       endif
17814
17815 !-------TESTING CODE
17816 !el      if (checkstop) then
17817         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
17818              "CHECKSTOP",rij,eij,ed
17819         echeck(jcheck)=eij
17820 !el      endif
17821       enddo
17822       if (checkstop) then
17823         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
17824       endif
17825       enddo
17826       if (checkstop) then
17827         transgrad=.true.
17828         checkstop=.false.
17829       endif
17830 !-------END TESTING CODE
17831
17832       do k=1,3
17833         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
17834         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
17835       enddo
17836       do k=1,3
17837         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
17838       enddo
17839       do k=1,3
17840         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
17841              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
17842              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
17843         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
17844              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
17845              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
17846       enddo
17847 !grad      do k=i,j-1
17848 !grad        do l=1,3
17849 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
17850 !grad        enddo
17851 !grad      enddo
17852
17853       do l=1,3
17854         gvdwc(l,i)=gvdwc(l,i)-gg(l)
17855         gvdwc(l,j)=gvdwc(l,j)+gg(l)
17856       enddo
17857
17858       return
17859       end subroutine dyn_ssbond_ene
17860 !--------------------------------------------------------------------------
17861          subroutine triple_ssbond_ene(resi,resj,resk,eij)
17862 !      implicit none
17863 !      Includes
17864       use calc_data
17865       use comm_sschecks
17866 !      include 'DIMENSIONS'
17867 !      include 'COMMON.SBRIDGE'
17868 !      include 'COMMON.CHAIN'
17869 !      include 'COMMON.DERIV'
17870 !      include 'COMMON.LOCAL'
17871 !      include 'COMMON.INTERACT'
17872 !      include 'COMMON.VAR'
17873 !      include 'COMMON.IOUNITS'
17874 !      include 'COMMON.CALC'
17875 #ifndef CLUST
17876 #ifndef WHAM
17877        use MD_data
17878 !      include 'COMMON.MD'
17879 !      use MD, only: totT,t_bath
17880 #endif
17881 #endif
17882       double precision h_base
17883       external h_base
17884
17885 !c     Input arguments
17886       integer resi,resj,resk,m,itypi,itypj,itypk
17887
17888 !c     Output arguments
17889       double precision eij,eij1,eij2,eij3
17890
17891 !c     Local variables
17892       logical havebond
17893 !c      integer itypi,itypj,k,l
17894       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
17895       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
17896       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
17897       double precision sig0ij,ljd,sig,fac,e1,e2
17898       double precision dcosom1(3),dcosom2(3),ed
17899       double precision pom1,pom2
17900       double precision ljA,ljB,ljXs
17901       double precision d_ljB(1:3)
17902       double precision ssA,ssB,ssC,ssXs
17903       double precision ssxm,ljxm,ssm,ljm
17904       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
17905       eij=0.0
17906       if (dtriss.eq.0) return
17907       i=resi
17908       j=resj
17909       k=resk
17910 !C      write(iout,*) resi,resj,resk
17911       itypi=itype(i,1)
17912       dxi=dc_norm(1,nres+i)
17913       dyi=dc_norm(2,nres+i)
17914       dzi=dc_norm(3,nres+i)
17915       dsci_inv=vbld_inv(i+nres)
17916       xi=c(1,nres+i)
17917       yi=c(2,nres+i)
17918       zi=c(3,nres+i)
17919       itypj=itype(j,1)
17920       xj=c(1,nres+j)
17921       yj=c(2,nres+j)
17922       zj=c(3,nres+j)
17923
17924       dxj=dc_norm(1,nres+j)
17925       dyj=dc_norm(2,nres+j)
17926       dzj=dc_norm(3,nres+j)
17927       dscj_inv=vbld_inv(j+nres)
17928       itypk=itype(k,1)
17929       xk=c(1,nres+k)
17930       yk=c(2,nres+k)
17931       zk=c(3,nres+k)
17932
17933       dxk=dc_norm(1,nres+k)
17934       dyk=dc_norm(2,nres+k)
17935       dzk=dc_norm(3,nres+k)
17936       dscj_inv=vbld_inv(k+nres)
17937       xij=xj-xi
17938       xik=xk-xi
17939       xjk=xk-xj
17940       yij=yj-yi
17941       yik=yk-yi
17942       yjk=yk-yj
17943       zij=zj-zi
17944       zik=zk-zi
17945       zjk=zk-zj
17946       rrij=(xij*xij+yij*yij+zij*zij)
17947       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17948       rrik=(xik*xik+yik*yik+zik*zik)
17949       rik=dsqrt(rrik)
17950       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
17951       rjk=dsqrt(rrjk)
17952 !C there are three combination of distances for each trisulfide bonds
17953 !C The first case the ith atom is the center
17954 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
17955 !C distance y is second distance the a,b,c,d are parameters derived for
17956 !C this problem d parameter was set as a penalty currenlty set to 1.
17957       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
17958       eij1=0.0d0
17959       else
17960       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
17961       endif
17962 !C second case jth atom is center
17963       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
17964       eij2=0.0d0
17965       else
17966       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
17967       endif
17968 !C the third case kth atom is the center
17969       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
17970       eij3=0.0d0
17971       else
17972       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
17973       endif
17974 !C      eij2=0.0
17975 !C      eij3=0.0
17976 !C      eij1=0.0
17977       eij=eij1+eij2+eij3
17978 !C      write(iout,*)i,j,k,eij
17979 !C The energy penalty calculated now time for the gradient part
17980 !C derivative over rij
17981       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
17982       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
17983             gg(1)=xij*fac/rij
17984             gg(2)=yij*fac/rij
17985             gg(3)=zij*fac/rij
17986       do m=1,3
17987         gvdwx(m,i)=gvdwx(m,i)-gg(m)
17988         gvdwx(m,j)=gvdwx(m,j)+gg(m)
17989       enddo
17990
17991       do l=1,3
17992         gvdwc(l,i)=gvdwc(l,i)-gg(l)
17993         gvdwc(l,j)=gvdwc(l,j)+gg(l)
17994       enddo
17995 !C now derivative over rik
17996       fac=-eij1**2/dtriss* &
17997       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
17998       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
17999             gg(1)=xik*fac/rik
18000             gg(2)=yik*fac/rik
18001             gg(3)=zik*fac/rik
18002       do m=1,3
18003         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18004         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18005       enddo
18006       do l=1,3
18007         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18008         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18009       enddo
18010 !C now derivative over rjk
18011       fac=-eij2**2/dtriss* &
18012       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18013       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18014             gg(1)=xjk*fac/rjk
18015             gg(2)=yjk*fac/rjk
18016             gg(3)=zjk*fac/rjk
18017       do m=1,3
18018         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18019         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18020       enddo
18021       do l=1,3
18022         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18023         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18024       enddo
18025       return
18026       end subroutine triple_ssbond_ene
18027
18028
18029
18030 !-----------------------------------------------------------------------------
18031       real(kind=8) function h_base(x,deriv)
18032 !     A smooth function going 0->1 in range [0,1]
18033 !     It should NOT be called outside range [0,1], it will not work there.
18034       implicit none
18035
18036 !     Input arguments
18037       real(kind=8) :: x
18038
18039 !     Output arguments
18040       real(kind=8) :: deriv
18041
18042 !     Local variables
18043       real(kind=8) :: xsq
18044
18045
18046 !     Two parabolas put together.  First derivative zero at extrema
18047 !$$$      if (x.lt.0.5D0) then
18048 !$$$        h_base=2.0D0*x*x
18049 !$$$        deriv=4.0D0*x
18050 !$$$      else
18051 !$$$        deriv=1.0D0-x
18052 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18053 !$$$        deriv=4.0D0*deriv
18054 !$$$      endif
18055
18056 !     Third degree polynomial.  First derivative zero at extrema
18057       h_base=x*x*(3.0d0-2.0d0*x)
18058       deriv=6.0d0*x*(1.0d0-x)
18059
18060 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18061 !$$$      xsq=x*x
18062 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18063 !$$$      deriv=x-1.0d0
18064 !$$$      deriv=deriv*deriv
18065 !$$$      deriv=30.0d0*xsq*deriv
18066
18067       return
18068       end function h_base
18069 !-----------------------------------------------------------------------------
18070       subroutine dyn_set_nss
18071 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18072 !      implicit none
18073       use MD_data, only: totT,t_bath
18074 !     Includes
18075 !      include 'DIMENSIONS'
18076 #ifdef MPI
18077       include "mpif.h"
18078 #endif
18079 !      include 'COMMON.SBRIDGE'
18080 !      include 'COMMON.CHAIN'
18081 !      include 'COMMON.IOUNITS'
18082 !      include 'COMMON.SETUP'
18083 !      include 'COMMON.MD'
18084 !     Local variables
18085       real(kind=8) :: emin
18086       integer :: i,j,imin,ierr
18087       integer :: diff,allnss,newnss
18088       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18089                 newihpb,newjhpb
18090       logical :: found
18091       integer,dimension(0:nfgtasks) :: i_newnss
18092       integer,dimension(0:nfgtasks) :: displ
18093       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18094       integer :: g_newnss
18095
18096       allnss=0
18097       do i=1,nres-1
18098         do j=i+1,nres
18099           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18100             allnss=allnss+1
18101             allflag(allnss)=0
18102             allihpb(allnss)=i
18103             alljhpb(allnss)=j
18104           endif
18105         enddo
18106       enddo
18107
18108 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18109
18110  1    emin=1.0d300
18111       do i=1,allnss
18112         if (allflag(i).eq.0 .and. &
18113              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18114           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18115           imin=i
18116         endif
18117       enddo
18118       if (emin.lt.1.0d300) then
18119         allflag(imin)=1
18120         do i=1,allnss
18121           if (allflag(i).eq.0 .and. &
18122                (allihpb(i).eq.allihpb(imin) .or. &
18123                alljhpb(i).eq.allihpb(imin) .or. &
18124                allihpb(i).eq.alljhpb(imin) .or. &
18125                alljhpb(i).eq.alljhpb(imin))) then
18126             allflag(i)=-1
18127           endif
18128         enddo
18129         goto 1
18130       endif
18131
18132 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18133
18134       newnss=0
18135       do i=1,allnss
18136         if (allflag(i).eq.1) then
18137           newnss=newnss+1
18138           newihpb(newnss)=allihpb(i)
18139           newjhpb(newnss)=alljhpb(i)
18140         endif
18141       enddo
18142
18143 #ifdef MPI
18144       if (nfgtasks.gt.1)then
18145
18146         call MPI_Reduce(newnss,g_newnss,1,&
18147           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18148         call MPI_Gather(newnss,1,MPI_INTEGER,&
18149                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18150         displ(0)=0
18151         do i=1,nfgtasks-1,1
18152           displ(i)=i_newnss(i-1)+displ(i-1)
18153         enddo
18154         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18155                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18156                          king,FG_COMM,IERR)
18157         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18158                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18159                          king,FG_COMM,IERR)
18160         if(fg_rank.eq.0) then
18161 !         print *,'g_newnss',g_newnss
18162 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18163 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18164          newnss=g_newnss
18165          do i=1,newnss
18166           newihpb(i)=g_newihpb(i)
18167           newjhpb(i)=g_newjhpb(i)
18168          enddo
18169         endif
18170       endif
18171 #endif
18172
18173       diff=newnss-nss
18174
18175 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18176 !       print *,newnss,nss,maxdim
18177       do i=1,nss
18178         found=.false.
18179 !        print *,newnss
18180         do j=1,newnss
18181 !!          print *,j
18182           if (idssb(i).eq.newihpb(j) .and. &
18183                jdssb(i).eq.newjhpb(j)) found=.true.
18184         enddo
18185 #ifndef CLUST
18186 #ifndef WHAM
18187 !        write(iout,*) "found",found,i,j
18188         if (.not.found.and.fg_rank.eq.0) &
18189             write(iout,'(a15,f12.2,f8.1,2i5)') &
18190              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18191 #endif
18192 #endif
18193       enddo
18194
18195       do i=1,newnss
18196         found=.false.
18197         do j=1,nss
18198 !          print *,i,j
18199           if (newihpb(i).eq.idssb(j) .and. &
18200                newjhpb(i).eq.jdssb(j)) found=.true.
18201         enddo
18202 #ifndef CLUST
18203 #ifndef WHAM
18204 !        write(iout,*) "found",found,i,j
18205         if (.not.found.and.fg_rank.eq.0) &
18206             write(iout,'(a15,f12.2,f8.1,2i5)') &
18207              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18208 #endif
18209 #endif
18210       enddo
18211
18212       nss=newnss
18213       do i=1,nss
18214         idssb(i)=newihpb(i)
18215         jdssb(i)=newjhpb(i)
18216       enddo
18217
18218       return
18219       end subroutine dyn_set_nss
18220 ! Lipid transfer energy function
18221       subroutine Eliptransfer(eliptran)
18222 !C this is done by Adasko
18223 !C      print *,"wchodze"
18224 !C structure of box:
18225 !C      water
18226 !C--bordliptop-- buffore starts
18227 !C--bufliptop--- here true lipid starts
18228 !C      lipid
18229 !C--buflipbot--- lipid ends buffore starts
18230 !C--bordlipbot--buffore ends
18231       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18232       integer :: i
18233       eliptran=0.0
18234 !      print *, "I am in eliptran"
18235       do i=ilip_start,ilip_end
18236 !C       do i=1,1
18237         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18238          cycle
18239
18240         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18241         if (positi.le.0.0) positi=positi+boxzsize
18242 !C        print *,i
18243 !C first for peptide groups
18244 !c for each residue check if it is in lipid or lipid water border area
18245        if ((positi.gt.bordlipbot)  &
18246       .and.(positi.lt.bordliptop)) then
18247 !C the energy transfer exist
18248         if (positi.lt.buflipbot) then
18249 !C what fraction I am in
18250          fracinbuf=1.0d0-      &
18251              ((positi-bordlipbot)/lipbufthick)
18252 !C lipbufthick is thickenes of lipid buffore
18253          sslip=sscalelip(fracinbuf)
18254          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18255          eliptran=eliptran+sslip*pepliptran
18256          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18257          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18258 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18259
18260 !C        print *,"doing sccale for lower part"
18261 !C         print *,i,sslip,fracinbuf,ssgradlip
18262         elseif (positi.gt.bufliptop) then
18263          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18264          sslip=sscalelip(fracinbuf)
18265          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18266          eliptran=eliptran+sslip*pepliptran
18267          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18268          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18269 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18270 !C          print *, "doing sscalefor top part"
18271 !C         print *,i,sslip,fracinbuf,ssgradlip
18272         else
18273          eliptran=eliptran+pepliptran
18274 !C         print *,"I am in true lipid"
18275         endif
18276 !C       else
18277 !C       eliptran=elpitran+0.0 ! I am in water
18278        endif
18279        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18280        enddo
18281 ! here starts the side chain transfer
18282        do i=ilip_start,ilip_end
18283         if (itype(i,1).eq.ntyp1) cycle
18284         positi=(mod(c(3,i+nres),boxzsize))
18285         if (positi.le.0) positi=positi+boxzsize
18286 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18287 !c for each residue check if it is in lipid or lipid water border area
18288 !C       respos=mod(c(3,i+nres),boxzsize)
18289 !C       print *,positi,bordlipbot,buflipbot
18290        if ((positi.gt.bordlipbot) &
18291        .and.(positi.lt.bordliptop)) then
18292 !C the energy transfer exist
18293         if (positi.lt.buflipbot) then
18294          fracinbuf=1.0d0-   &
18295            ((positi-bordlipbot)/lipbufthick)
18296 !C lipbufthick is thickenes of lipid buffore
18297          sslip=sscalelip(fracinbuf)
18298          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18299          eliptran=eliptran+sslip*liptranene(itype(i,1))
18300          gliptranx(3,i)=gliptranx(3,i) &
18301       +ssgradlip*liptranene(itype(i,1))
18302          gliptranc(3,i-1)= gliptranc(3,i-1) &
18303       +ssgradlip*liptranene(itype(i,1))
18304 !C         print *,"doing sccale for lower part"
18305         elseif (positi.gt.bufliptop) then
18306          fracinbuf=1.0d0-  &
18307       ((bordliptop-positi)/lipbufthick)
18308          sslip=sscalelip(fracinbuf)
18309          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18310          eliptran=eliptran+sslip*liptranene(itype(i,1))
18311          gliptranx(3,i)=gliptranx(3,i)  &
18312        +ssgradlip*liptranene(itype(i,1))
18313          gliptranc(3,i-1)= gliptranc(3,i-1) &
18314       +ssgradlip*liptranene(itype(i,1))
18315 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18316         else
18317          eliptran=eliptran+liptranene(itype(i,1))
18318 !C         print *,"I am in true lipid"
18319         endif
18320         endif ! if in lipid or buffor
18321 !C       else
18322 !C       eliptran=elpitran+0.0 ! I am in water
18323         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18324        enddo
18325        return
18326        end  subroutine Eliptransfer
18327 !----------------------------------NANO FUNCTIONS
18328 !C-----------------------------------------------------------------------
18329 !C-----------------------------------------------------------
18330 !C This subroutine is to mimic the histone like structure but as well can be
18331 !C utilizet to nanostructures (infinit) small modification has to be used to
18332 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18333 !C gradient has to be modified at the ends
18334 !C The energy function is Kihara potential
18335 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18336 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18337 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18338 !C simple Kihara potential
18339       subroutine calctube(Etube)
18340       real(kind=8),dimension(3) :: vectube
18341       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18342        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18343        sc_aa_tube,sc_bb_tube
18344       integer :: i,j,iti
18345       Etube=0.0d0
18346       do i=itube_start,itube_end
18347         enetube(i)=0.0d0
18348         enetube(i+nres)=0.0d0
18349       enddo
18350 !C first we calculate the distance from tube center
18351 !C for UNRES
18352        do i=itube_start,itube_end
18353 !C lets ommit dummy atoms for now
18354        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18355 !C now calculate distance from center of tube and direction vectors
18356       xmin=boxxsize
18357       ymin=boxysize
18358 ! Find minimum distance in periodic box
18359         do j=-1,1
18360          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18361          vectube(1)=vectube(1)+boxxsize*j
18362          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18363          vectube(2)=vectube(2)+boxysize*j
18364          xminact=abs(vectube(1)-tubecenter(1))
18365          yminact=abs(vectube(2)-tubecenter(2))
18366            if (xmin.gt.xminact) then
18367             xmin=xminact
18368             xtemp=vectube(1)
18369            endif
18370            if (ymin.gt.yminact) then
18371              ymin=yminact
18372              ytemp=vectube(2)
18373             endif
18374          enddo
18375       vectube(1)=xtemp
18376       vectube(2)=ytemp
18377       vectube(1)=vectube(1)-tubecenter(1)
18378       vectube(2)=vectube(2)-tubecenter(2)
18379
18380 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18381 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18382
18383 !C as the tube is infinity we do not calculate the Z-vector use of Z
18384 !C as chosen axis
18385       vectube(3)=0.0d0
18386 !C now calculte the distance
18387        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18388 !C now normalize vector
18389       vectube(1)=vectube(1)/tub_r
18390       vectube(2)=vectube(2)/tub_r
18391 !C calculte rdiffrence between r and r0
18392       rdiff=tub_r-tubeR0
18393 !C and its 6 power
18394       rdiff6=rdiff**6.0d0
18395 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18396        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18397 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18398 !C       print *,rdiff,rdiff6,pep_aa_tube
18399 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18400 !C now we calculate gradient
18401        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18402             6.0d0*pep_bb_tube)/rdiff6/rdiff
18403 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18404 !C     &rdiff,fac
18405 !C now direction of gg_tube vector
18406         do j=1,3
18407         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18408         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18409         enddo
18410         enddo
18411 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18412 !C        print *,gg_tube(1,0),"TU"
18413
18414
18415        do i=itube_start,itube_end
18416 !C Lets not jump over memory as we use many times iti
18417          iti=itype(i,1)
18418 !C lets ommit dummy atoms for now
18419          if ((iti.eq.ntyp1)  &
18420 !C in UNRES uncomment the line below as GLY has no side-chain...
18421 !C      .or.(iti.eq.10)
18422         ) cycle
18423       xmin=boxxsize
18424       ymin=boxysize
18425         do j=-1,1
18426          vectube(1)=mod((c(1,i+nres)),boxxsize)
18427          vectube(1)=vectube(1)+boxxsize*j
18428          vectube(2)=mod((c(2,i+nres)),boxysize)
18429          vectube(2)=vectube(2)+boxysize*j
18430
18431          xminact=abs(vectube(1)-tubecenter(1))
18432          yminact=abs(vectube(2)-tubecenter(2))
18433            if (xmin.gt.xminact) then
18434             xmin=xminact
18435             xtemp=vectube(1)
18436            endif
18437            if (ymin.gt.yminact) then
18438              ymin=yminact
18439              ytemp=vectube(2)
18440             endif
18441          enddo
18442       vectube(1)=xtemp
18443       vectube(2)=ytemp
18444 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18445 !C     &     tubecenter(2)
18446       vectube(1)=vectube(1)-tubecenter(1)
18447       vectube(2)=vectube(2)-tubecenter(2)
18448
18449 !C as the tube is infinity we do not calculate the Z-vector use of Z
18450 !C as chosen axis
18451       vectube(3)=0.0d0
18452 !C now calculte the distance
18453        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18454 !C now normalize vector
18455       vectube(1)=vectube(1)/tub_r
18456       vectube(2)=vectube(2)/tub_r
18457
18458 !C calculte rdiffrence between r and r0
18459       rdiff=tub_r-tubeR0
18460 !C and its 6 power
18461       rdiff6=rdiff**6.0d0
18462 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18463        sc_aa_tube=sc_aa_tube_par(iti)
18464        sc_bb_tube=sc_bb_tube_par(iti)
18465        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18466        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18467              6.0d0*sc_bb_tube/rdiff6/rdiff
18468 !C now direction of gg_tube vector
18469          do j=1,3
18470           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18471           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18472          enddo
18473         enddo
18474         do i=itube_start,itube_end
18475           Etube=Etube+enetube(i)+enetube(i+nres)
18476         enddo
18477 !C        print *,"ETUBE", etube
18478         return
18479         end subroutine calctube
18480 !C TO DO 1) add to total energy
18481 !C       2) add to gradient summation
18482 !C       3) add reading parameters (AND of course oppening of PARAM file)
18483 !C       4) add reading the center of tube
18484 !C       5) add COMMONs
18485 !C       6) add to zerograd
18486 !C       7) allocate matrices
18487
18488
18489 !C-----------------------------------------------------------------------
18490 !C-----------------------------------------------------------
18491 !C This subroutine is to mimic the histone like structure but as well can be
18492 !C utilizet to nanostructures (infinit) small modification has to be used to
18493 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18494 !C gradient has to be modified at the ends
18495 !C The energy function is Kihara potential
18496 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18497 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18498 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18499 !C simple Kihara potential
18500       subroutine calctube2(Etube)
18501             real(kind=8),dimension(3) :: vectube
18502       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18503        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18504        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18505       integer:: i,j,iti
18506       Etube=0.0d0
18507       do i=itube_start,itube_end
18508         enetube(i)=0.0d0
18509         enetube(i+nres)=0.0d0
18510       enddo
18511 !C first we calculate the distance from tube center
18512 !C first sugare-phosphate group for NARES this would be peptide group
18513 !C for UNRES
18514        do i=itube_start,itube_end
18515 !C lets ommit dummy atoms for now
18516
18517        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18518 !C now calculate distance from center of tube and direction vectors
18519 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18520 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18521 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18522 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18523       xmin=boxxsize
18524       ymin=boxysize
18525         do j=-1,1
18526          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18527          vectube(1)=vectube(1)+boxxsize*j
18528          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18529          vectube(2)=vectube(2)+boxysize*j
18530
18531          xminact=abs(vectube(1)-tubecenter(1))
18532          yminact=abs(vectube(2)-tubecenter(2))
18533            if (xmin.gt.xminact) then
18534             xmin=xminact
18535             xtemp=vectube(1)
18536            endif
18537            if (ymin.gt.yminact) then
18538              ymin=yminact
18539              ytemp=vectube(2)
18540             endif
18541          enddo
18542       vectube(1)=xtemp
18543       vectube(2)=ytemp
18544       vectube(1)=vectube(1)-tubecenter(1)
18545       vectube(2)=vectube(2)-tubecenter(2)
18546
18547 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18548 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18549
18550 !C as the tube is infinity we do not calculate the Z-vector use of Z
18551 !C as chosen axis
18552       vectube(3)=0.0d0
18553 !C now calculte the distance
18554        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18555 !C now normalize vector
18556       vectube(1)=vectube(1)/tub_r
18557       vectube(2)=vectube(2)/tub_r
18558 !C calculte rdiffrence between r and r0
18559       rdiff=tub_r-tubeR0
18560 !C and its 6 power
18561       rdiff6=rdiff**6.0d0
18562 !C THIS FRAGMENT MAKES TUBE FINITE
18563         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18564         if (positi.le.0) positi=positi+boxzsize
18565 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18566 !c for each residue check if it is in lipid or lipid water border area
18567 !C       respos=mod(c(3,i+nres),boxzsize)
18568 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18569        if ((positi.gt.bordtubebot)  &
18570         .and.(positi.lt.bordtubetop)) then
18571 !C the energy transfer exist
18572         if (positi.lt.buftubebot) then
18573          fracinbuf=1.0d0-  &
18574            ((positi-bordtubebot)/tubebufthick)
18575 !C lipbufthick is thickenes of lipid buffore
18576          sstube=sscalelip(fracinbuf)
18577          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18578 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18579          enetube(i)=enetube(i)+sstube*tubetranenepep
18580 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18581 !C     &+ssgradtube*tubetranene(itype(i,1))
18582 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18583 !C     &+ssgradtube*tubetranene(itype(i,1))
18584 !C         print *,"doing sccale for lower part"
18585         elseif (positi.gt.buftubetop) then
18586          fracinbuf=1.0d0-  &
18587         ((bordtubetop-positi)/tubebufthick)
18588          sstube=sscalelip(fracinbuf)
18589          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18590          enetube(i)=enetube(i)+sstube*tubetranenepep
18591 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18592 !C     &+ssgradtube*tubetranene(itype(i,1))
18593 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18594 !C     &+ssgradtube*tubetranene(itype(i,1))
18595 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18596         else
18597          sstube=1.0d0
18598          ssgradtube=0.0d0
18599          enetube(i)=enetube(i)+sstube*tubetranenepep
18600 !C         print *,"I am in true lipid"
18601         endif
18602         else
18603 !C          sstube=0.0d0
18604 !C          ssgradtube=0.0d0
18605         cycle
18606         endif ! if in lipid or buffor
18607
18608 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18609        enetube(i)=enetube(i)+sstube* &
18610         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18611 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18612 !C       print *,rdiff,rdiff6,pep_aa_tube
18613 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18614 !C now we calculate gradient
18615        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18616              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18617 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18618 !C     &rdiff,fac
18619
18620 !C now direction of gg_tube vector
18621        do j=1,3
18622         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18623         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18624         enddo
18625          gg_tube(3,i)=gg_tube(3,i)  &
18626        +ssgradtube*enetube(i)/sstube/2.0d0
18627          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18628        +ssgradtube*enetube(i)/sstube/2.0d0
18629
18630         enddo
18631 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18632 !C        print *,gg_tube(1,0),"TU"
18633         do i=itube_start,itube_end
18634 !C Lets not jump over memory as we use many times iti
18635          iti=itype(i,1)
18636 !C lets ommit dummy atoms for now
18637          if ((iti.eq.ntyp1) &
18638 !!C in UNRES uncomment the line below as GLY has no side-chain...
18639            .or.(iti.eq.10) &
18640           ) cycle
18641           vectube(1)=c(1,i+nres)
18642           vectube(1)=mod(vectube(1),boxxsize)
18643           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18644           vectube(2)=c(2,i+nres)
18645           vectube(2)=mod(vectube(2),boxysize)
18646           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18647
18648       vectube(1)=vectube(1)-tubecenter(1)
18649       vectube(2)=vectube(2)-tubecenter(2)
18650 !C THIS FRAGMENT MAKES TUBE FINITE
18651         positi=(mod(c(3,i+nres),boxzsize))
18652         if (positi.le.0) positi=positi+boxzsize
18653 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18654 !c for each residue check if it is in lipid or lipid water border area
18655 !C       respos=mod(c(3,i+nres),boxzsize)
18656 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18657
18658        if ((positi.gt.bordtubebot)  &
18659         .and.(positi.lt.bordtubetop)) then
18660 !C the energy transfer exist
18661         if (positi.lt.buftubebot) then
18662          fracinbuf=1.0d0- &
18663             ((positi-bordtubebot)/tubebufthick)
18664 !C lipbufthick is thickenes of lipid buffore
18665          sstube=sscalelip(fracinbuf)
18666          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18667 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18668          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18669 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18670 !C     &+ssgradtube*tubetranene(itype(i,1))
18671 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18672 !C     &+ssgradtube*tubetranene(itype(i,1))
18673 !C         print *,"doing sccale for lower part"
18674         elseif (positi.gt.buftubetop) then
18675          fracinbuf=1.0d0- &
18676         ((bordtubetop-positi)/tubebufthick)
18677
18678          sstube=sscalelip(fracinbuf)
18679          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18680          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18681 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18682 !C     &+ssgradtube*tubetranene(itype(i,1))
18683 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18684 !C     &+ssgradtube*tubetranene(itype(i,1))
18685 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18686         else
18687          sstube=1.0d0
18688          ssgradtube=0.0d0
18689          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18690 !C         print *,"I am in true lipid"
18691         endif
18692         else
18693 !C          sstube=0.0d0
18694 !C          ssgradtube=0.0d0
18695         cycle
18696         endif ! if in lipid or buffor
18697 !CEND OF FINITE FRAGMENT
18698 !C as the tube is infinity we do not calculate the Z-vector use of Z
18699 !C as chosen axis
18700       vectube(3)=0.0d0
18701 !C now calculte the distance
18702        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18703 !C now normalize vector
18704       vectube(1)=vectube(1)/tub_r
18705       vectube(2)=vectube(2)/tub_r
18706 !C calculte rdiffrence between r and r0
18707       rdiff=tub_r-tubeR0
18708 !C and its 6 power
18709       rdiff6=rdiff**6.0d0
18710 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18711        sc_aa_tube=sc_aa_tube_par(iti)
18712        sc_bb_tube=sc_bb_tube_par(iti)
18713        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
18714                        *sstube+enetube(i+nres)
18715 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18716 !C now we calculate gradient
18717        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
18718             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
18719 !C now direction of gg_tube vector
18720          do j=1,3
18721           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18722           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18723          enddo
18724          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
18725        +ssgradtube*enetube(i+nres)/sstube
18726          gg_tube(3,i-1)= gg_tube(3,i-1) &
18727        +ssgradtube*enetube(i+nres)/sstube
18728
18729         enddo
18730         do i=itube_start,itube_end
18731           Etube=Etube+enetube(i)+enetube(i+nres)
18732         enddo
18733 !C        print *,"ETUBE", etube
18734         return
18735         end subroutine calctube2
18736 !=====================================================================================================================================
18737       subroutine calcnano(Etube)
18738       real(kind=8),dimension(3) :: vectube
18739
18740       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18741        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
18742        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
18743        integer:: i,j,iti
18744
18745       Etube=0.0d0
18746 !      print *,itube_start,itube_end,"poczatek"
18747       do i=itube_start,itube_end
18748         enetube(i)=0.0d0
18749         enetube(i+nres)=0.0d0
18750       enddo
18751 !C first we calculate the distance from tube center
18752 !C first sugare-phosphate group for NARES this would be peptide group
18753 !C for UNRES
18754        do i=itube_start,itube_end
18755 !C lets ommit dummy atoms for now
18756        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18757 !C now calculate distance from center of tube and direction vectors
18758       xmin=boxxsize
18759       ymin=boxysize
18760       zmin=boxzsize
18761
18762         do j=-1,1
18763          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18764          vectube(1)=vectube(1)+boxxsize*j
18765          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18766          vectube(2)=vectube(2)+boxysize*j
18767          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18768          vectube(3)=vectube(3)+boxzsize*j
18769
18770
18771          xminact=dabs(vectube(1)-tubecenter(1))
18772          yminact=dabs(vectube(2)-tubecenter(2))
18773          zminact=dabs(vectube(3)-tubecenter(3))
18774
18775            if (xmin.gt.xminact) then
18776             xmin=xminact
18777             xtemp=vectube(1)
18778            endif
18779            if (ymin.gt.yminact) then
18780              ymin=yminact
18781              ytemp=vectube(2)
18782             endif
18783            if (zmin.gt.zminact) then
18784              zmin=zminact
18785              ztemp=vectube(3)
18786             endif
18787          enddo
18788       vectube(1)=xtemp
18789       vectube(2)=ytemp
18790       vectube(3)=ztemp
18791
18792       vectube(1)=vectube(1)-tubecenter(1)
18793       vectube(2)=vectube(2)-tubecenter(2)
18794       vectube(3)=vectube(3)-tubecenter(3)
18795
18796 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18797 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18798 !C as the tube is infinity we do not calculate the Z-vector use of Z
18799 !C as chosen axis
18800 !C      vectube(3)=0.0d0
18801 !C now calculte the distance
18802        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18803 !C now normalize vector
18804       vectube(1)=vectube(1)/tub_r
18805       vectube(2)=vectube(2)/tub_r
18806       vectube(3)=vectube(3)/tub_r
18807 !C calculte rdiffrence between r and r0
18808       rdiff=tub_r-tubeR0
18809 !C and its 6 power
18810       rdiff6=rdiff**6.0d0
18811 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18812        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18813 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18814 !C       print *,rdiff,rdiff6,pep_aa_tube
18815 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18816 !C now we calculate gradient
18817        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
18818             6.0d0*pep_bb_tube)/rdiff6/rdiff
18819 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18820 !C     &rdiff,fac
18821          if (acavtubpep.eq.0.0d0) then
18822 !C go to 667
18823          enecavtube(i)=0.0
18824          faccav=0.0
18825          else
18826          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
18827          enecavtube(i)=  &
18828         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
18829         /denominator
18830          enecavtube(i)=0.0
18831          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
18832         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
18833         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
18834         /denominator**2.0d0
18835 !C         faccav=0.0
18836 !C         fac=fac+faccav
18837 !C 667     continue
18838          endif
18839           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
18840         do j=1,3
18841         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18842         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18843         enddo
18844         enddo
18845
18846        do i=itube_start,itube_end
18847         enecavtube(i)=0.0d0
18848 !C Lets not jump over memory as we use many times iti
18849          iti=itype(i,1)
18850 !C lets ommit dummy atoms for now
18851          if ((iti.eq.ntyp1) &
18852 !C in UNRES uncomment the line below as GLY has no side-chain...
18853 !C      .or.(iti.eq.10)
18854          ) cycle
18855       xmin=boxxsize
18856       ymin=boxysize
18857       zmin=boxzsize
18858         do j=-1,1
18859          vectube(1)=dmod((c(1,i+nres)),boxxsize)
18860          vectube(1)=vectube(1)+boxxsize*j
18861          vectube(2)=dmod((c(2,i+nres)),boxysize)
18862          vectube(2)=vectube(2)+boxysize*j
18863          vectube(3)=dmod((c(3,i+nres)),boxzsize)
18864          vectube(3)=vectube(3)+boxzsize*j
18865
18866
18867          xminact=dabs(vectube(1)-tubecenter(1))
18868          yminact=dabs(vectube(2)-tubecenter(2))
18869          zminact=dabs(vectube(3)-tubecenter(3))
18870
18871            if (xmin.gt.xminact) then
18872             xmin=xminact
18873             xtemp=vectube(1)
18874            endif
18875            if (ymin.gt.yminact) then
18876              ymin=yminact
18877              ytemp=vectube(2)
18878             endif
18879            if (zmin.gt.zminact) then
18880              zmin=zminact
18881              ztemp=vectube(3)
18882             endif
18883          enddo
18884       vectube(1)=xtemp
18885       vectube(2)=ytemp
18886       vectube(3)=ztemp
18887
18888 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18889 !C     &     tubecenter(2)
18890       vectube(1)=vectube(1)-tubecenter(1)
18891       vectube(2)=vectube(2)-tubecenter(2)
18892       vectube(3)=vectube(3)-tubecenter(3)
18893 !C now calculte the distance
18894        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18895 !C now normalize vector
18896       vectube(1)=vectube(1)/tub_r
18897       vectube(2)=vectube(2)/tub_r
18898       vectube(3)=vectube(3)/tub_r
18899
18900 !C calculte rdiffrence between r and r0
18901       rdiff=tub_r-tubeR0
18902 !C and its 6 power
18903       rdiff6=rdiff**6.0d0
18904        sc_aa_tube=sc_aa_tube_par(iti)
18905        sc_bb_tube=sc_bb_tube_par(iti)
18906        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18907 !C       enetube(i+nres)=0.0d0
18908 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18909 !C now we calculate gradient
18910        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
18911             6.0d0*sc_bb_tube/rdiff6/rdiff
18912 !C       fac=0.0
18913 !C now direction of gg_tube vector
18914 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
18915          if (acavtub(iti).eq.0.0d0) then
18916 !C go to 667
18917          enecavtube(i+nres)=0.0d0
18918          faccav=0.0d0
18919          else
18920          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
18921          enecavtube(i+nres)=   &
18922         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
18923         /denominator
18924 !C         enecavtube(i)=0.0
18925          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
18926         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
18927         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
18928         /denominator**2.0d0
18929 !C         faccav=0.0
18930          fac=fac+faccav
18931 !C 667     continue
18932          endif
18933 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
18934 !C     &   enecavtube(i),faccav
18935 !C         print *,"licz=",
18936 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
18937 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
18938          do j=1,3
18939           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18940           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18941          enddo
18942           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
18943         enddo
18944
18945
18946
18947         do i=itube_start,itube_end
18948           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
18949          +enecavtube(i+nres)
18950         enddo
18951 !C        print *,"ETUBE", etube
18952         return
18953         end subroutine calcnano
18954
18955 !===============================================
18956 !--------------------------------------------------------------------------------
18957 !C first for shielding is setting of function of side-chains
18958
18959        subroutine set_shield_fac2
18960        real(kind=8) :: div77_81=0.974996043d0, &
18961         div4_81=0.2222222222d0
18962        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
18963          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
18964          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
18965          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
18966 !C the vector between center of side_chain and peptide group
18967        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
18968          pept_group,costhet_grad,cosphi_grad_long, &
18969          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
18970          sh_frac_dist_grad,pep_side
18971         integer i,j,k
18972 !C      write(2,*) "ivec",ivec_start,ivec_end
18973       do i=1,nres
18974         fac_shield(i)=0.0d0
18975         do j=1,3
18976         grad_shield(j,i)=0.0d0
18977         enddo
18978       enddo
18979       do i=ivec_start,ivec_end
18980 !C      do i=1,nres-1
18981 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
18982       ishield_list(i)=0
18983       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
18984 !Cif there two consequtive dummy atoms there is no peptide group between them
18985 !C the line below has to be changed for FGPROC>1
18986       VolumeTotal=0.0
18987       do k=1,nres
18988        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
18989        dist_pep_side=0.0
18990        dist_side_calf=0.0
18991        do j=1,3
18992 !C first lets set vector conecting the ithe side-chain with kth side-chain
18993       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
18994 !C      pep_side(j)=2.0d0
18995 !C and vector conecting the side-chain with its proper calfa
18996       side_calf(j)=c(j,k+nres)-c(j,k)
18997 !C      side_calf(j)=2.0d0
18998       pept_group(j)=c(j,i)-c(j,i+1)
18999 !C lets have their lenght
19000       dist_pep_side=pep_side(j)**2+dist_pep_side
19001       dist_side_calf=dist_side_calf+side_calf(j)**2
19002       dist_pept_group=dist_pept_group+pept_group(j)**2
19003       enddo
19004        dist_pep_side=sqrt(dist_pep_side)
19005        dist_pept_group=sqrt(dist_pept_group)
19006        dist_side_calf=sqrt(dist_side_calf)
19007       do j=1,3
19008         pep_side_norm(j)=pep_side(j)/dist_pep_side
19009         side_calf_norm(j)=dist_side_calf
19010       enddo
19011 !C now sscale fraction
19012        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19013 !C       print *,buff_shield,"buff"
19014 !C now sscale
19015         if (sh_frac_dist.le.0.0) cycle
19016 !C        print *,ishield_list(i),i
19017 !C If we reach here it means that this side chain reaches the shielding sphere
19018 !C Lets add him to the list for gradient
19019         ishield_list(i)=ishield_list(i)+1
19020 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19021 !C this list is essential otherwise problem would be O3
19022         shield_list(ishield_list(i),i)=k
19023 !C Lets have the sscale value
19024         if (sh_frac_dist.gt.1.0) then
19025          scale_fac_dist=1.0d0
19026          do j=1,3
19027          sh_frac_dist_grad(j)=0.0d0
19028          enddo
19029         else
19030          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19031                         *(2.0d0*sh_frac_dist-3.0d0)
19032          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19033                        /dist_pep_side/buff_shield*0.5d0
19034          do j=1,3
19035          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19036 !C         sh_frac_dist_grad(j)=0.0d0
19037 !C         scale_fac_dist=1.0d0
19038 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19039 !C     &                    sh_frac_dist_grad(j)
19040          enddo
19041         endif
19042 !C this is what is now we have the distance scaling now volume...
19043       short=short_r_sidechain(itype(k,1))
19044       long=long_r_sidechain(itype(k,1))
19045       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19046       sinthet=short/dist_pep_side*costhet
19047 !C now costhet_grad
19048 !C       costhet=0.6d0
19049 !C       sinthet=0.8
19050        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19051 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19052 !C     &             -short/dist_pep_side**2/costhet)
19053 !C       costhet_fac=0.0d0
19054        do j=1,3
19055          costhet_grad(j)=costhet_fac*pep_side(j)
19056        enddo
19057 !C remember for the final gradient multiply costhet_grad(j)
19058 !C for side_chain by factor -2 !
19059 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19060 !C pep_side0pept_group is vector multiplication
19061       pep_side0pept_group=0.0d0
19062       do j=1,3
19063       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19064       enddo
19065       cosalfa=(pep_side0pept_group/ &
19066       (dist_pep_side*dist_side_calf))
19067       fac_alfa_sin=1.0d0-cosalfa**2
19068       fac_alfa_sin=dsqrt(fac_alfa_sin)
19069       rkprim=fac_alfa_sin*(long-short)+short
19070 !C      rkprim=short
19071
19072 !C now costhet_grad
19073        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19074 !C       cosphi=0.6
19075        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19076        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19077            dist_pep_side**2)
19078 !C       sinphi=0.8
19079        do j=1,3
19080          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19081       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19082       *(long-short)/fac_alfa_sin*cosalfa/ &
19083       ((dist_pep_side*dist_side_calf))* &
19084       ((side_calf(j))-cosalfa* &
19085       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19086 !C       cosphi_grad_long(j)=0.0d0
19087         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19088       *(long-short)/fac_alfa_sin*cosalfa &
19089       /((dist_pep_side*dist_side_calf))* &
19090       (pep_side(j)- &
19091       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19092 !C       cosphi_grad_loc(j)=0.0d0
19093        enddo
19094 !C      print *,sinphi,sinthet
19095       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19096      &                    /VSolvSphere_div
19097 !C     &                    *wshield
19098 !C now the gradient...
19099       do j=1,3
19100       grad_shield(j,i)=grad_shield(j,i) &
19101 !C gradient po skalowaniu
19102                      +(sh_frac_dist_grad(j)*VofOverlap &
19103 !C  gradient po costhet
19104             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19105         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19106             sinphi/sinthet*costhet*costhet_grad(j) &
19107            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19108         )*wshield
19109 !C grad_shield_side is Cbeta sidechain gradient
19110       grad_shield_side(j,ishield_list(i),i)=&
19111              (sh_frac_dist_grad(j)*-2.0d0&
19112              *VofOverlap&
19113             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19114        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19115             sinphi/sinthet*costhet*costhet_grad(j)&
19116            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19117             )*wshield
19118
19119        grad_shield_loc(j,ishield_list(i),i)=   &
19120             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19121       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19122             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19123              ))&
19124              *wshield
19125       enddo
19126       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19127       enddo
19128       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19129
19130 !C      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19131       enddo
19132       return
19133       end subroutine set_shield_fac2
19134 !----------------------------------------------------------------------------
19135 ! SOUBROUTINE FOR AFM
19136        subroutine AFMvel(Eafmforce)
19137        use MD_data, only:totTafm
19138       real(kind=8),dimension(3) :: diffafm
19139       real(kind=8) :: afmdist,Eafmforce
19140        integer :: i
19141 !C Only for check grad COMMENT if not used for checkgrad
19142 !C      totT=3.0d0
19143 !C--------------------------------------------------------
19144 !C      print *,"wchodze"
19145       afmdist=0.0d0
19146       Eafmforce=0.0d0
19147       do i=1,3
19148       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19149       afmdist=afmdist+diffafm(i)**2
19150       enddo
19151       afmdist=dsqrt(afmdist)
19152 !      totTafm=3.0
19153       Eafmforce=0.5d0*forceAFMconst &
19154       *(distafminit+totTafm*velAFMconst-afmdist)**2
19155 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19156       do i=1,3
19157       gradafm(i,afmend-1)=-forceAFMconst* &
19158        (distafminit+totTafm*velAFMconst-afmdist) &
19159        *diffafm(i)/afmdist
19160       gradafm(i,afmbeg-1)=forceAFMconst* &
19161       (distafminit+totTafm*velAFMconst-afmdist) &
19162       *diffafm(i)/afmdist
19163       enddo
19164 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19165       return
19166       end subroutine AFMvel
19167 !---------------------------------------------------------
19168        subroutine AFMforce(Eafmforce)
19169
19170       real(kind=8),dimension(3) :: diffafm
19171 !      real(kind=8) ::afmdist
19172       real(kind=8) :: afmdist,Eafmforce
19173       integer :: i
19174       afmdist=0.0d0
19175       Eafmforce=0.0d0
19176       do i=1,3
19177       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19178       afmdist=afmdist+diffafm(i)**2
19179       enddo
19180       afmdist=dsqrt(afmdist)
19181 !      print *,afmdist,distafminit
19182       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19183       do i=1,3
19184       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19185       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19186       enddo
19187 !C      print *,'AFM',Eafmforce
19188       return
19189       end subroutine AFMforce
19190
19191 !-----------------------------------------------------------------------------
19192 #ifdef WHAM
19193       subroutine read_ssHist
19194 !      implicit none
19195 !      Includes
19196 !      include 'DIMENSIONS'
19197 !      include "DIMENSIONS.FREE"
19198 !      include 'COMMON.FREE'
19199 !     Local variables
19200       integer :: i,j
19201       character(len=80) :: controlcard
19202
19203       do i=1,dyn_nssHist
19204         call card_concat(controlcard,.true.)
19205         read(controlcard,*) &
19206              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19207       enddo
19208
19209       return
19210       end subroutine read_ssHist
19211 #endif
19212 !-----------------------------------------------------------------------------
19213       integer function indmat(i,j)
19214 !el
19215 ! get the position of the jth ijth fragment of the chain coordinate system
19216 ! in the fromto array.
19217         integer :: i,j
19218
19219         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19220       return
19221       end function indmat
19222 !-----------------------------------------------------------------------------
19223       real(kind=8) function sigm(x)
19224 !el
19225        real(kind=8) :: x
19226         sigm=0.25d0*x
19227       return
19228       end function sigm
19229 !-----------------------------------------------------------------------------
19230 !-----------------------------------------------------------------------------
19231       subroutine alloc_ener_arrays
19232 !EL Allocation of arrays used by module energy
19233       use MD_data, only: mset
19234 !el local variables
19235       integer :: i,j
19236
19237       if(nres.lt.100) then
19238         maxconts=nres
19239       elseif(nres.lt.200) then
19240         maxconts=0.8*nres       ! Max. number of contacts per residue
19241       else
19242         maxconts=0.6*nres ! (maxconts=maxres/4)
19243       endif
19244       maxcont=12*nres   ! Max. number of SC contacts
19245       maxvar=6*nres     ! Max. number of variables
19246 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19247       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19248 !----------------------
19249 ! arrays in subroutine init_int_table
19250 !el#ifdef MPI
19251 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19252 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19253 !el#endif
19254       allocate(nint_gr(nres))
19255       allocate(nscp_gr(nres))
19256       allocate(ielstart(nres))
19257       allocate(ielend(nres))
19258 !(maxres)
19259       allocate(istart(nres,maxint_gr))
19260       allocate(iend(nres,maxint_gr))
19261 !(maxres,maxint_gr)
19262       allocate(iscpstart(nres,maxint_gr))
19263       allocate(iscpend(nres,maxint_gr))
19264 !(maxres,maxint_gr)
19265       allocate(ielstart_vdw(nres))
19266       allocate(ielend_vdw(nres))
19267 !(maxres)
19268
19269       allocate(lentyp(0:nfgtasks-1))
19270 !(0:maxprocs-1)
19271 !----------------------
19272 ! commom.contacts
19273 !      common /contacts/
19274       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19275       allocate(icont(2,maxcont))
19276 !(2,maxcont)
19277 !      common /contacts1/
19278       allocate(num_cont(0:nres+4))
19279 !(maxres)
19280       allocate(jcont(maxconts,nres))
19281 !(maxconts,maxres)
19282       allocate(facont(maxconts,nres))
19283 !(maxconts,maxres)
19284       allocate(gacont(3,maxconts,nres))
19285 !(3,maxconts,maxres)
19286 !      common /contacts_hb/
19287       allocate(gacontp_hb1(3,maxconts,nres))
19288       allocate(gacontp_hb2(3,maxconts,nres))
19289       allocate(gacontp_hb3(3,maxconts,nres))
19290       allocate(gacontm_hb1(3,maxconts,nres))
19291       allocate(gacontm_hb2(3,maxconts,nres))
19292       allocate(gacontm_hb3(3,maxconts,nres))
19293       allocate(gacont_hbr(3,maxconts,nres))
19294       allocate(grij_hb_cont(3,maxconts,nres))
19295 !(3,maxconts,maxres)
19296       allocate(facont_hb(maxconts,nres))
19297
19298       allocate(ees0p(maxconts,nres))
19299       allocate(ees0m(maxconts,nres))
19300       allocate(d_cont(maxconts,nres))
19301       allocate(ees0plist(maxconts,nres))
19302
19303 !(maxconts,maxres)
19304       allocate(num_cont_hb(nres))
19305 !(maxres)
19306       allocate(jcont_hb(maxconts,nres))
19307 !(maxconts,maxres)
19308 !      common /rotat/
19309       allocate(Ug(2,2,nres))
19310       allocate(Ugder(2,2,nres))
19311       allocate(Ug2(2,2,nres))
19312       allocate(Ug2der(2,2,nres))
19313 !(2,2,maxres)
19314       allocate(obrot(2,nres))
19315       allocate(obrot2(2,nres))
19316       allocate(obrot_der(2,nres))
19317       allocate(obrot2_der(2,nres))
19318 !(2,maxres)
19319 !      common /precomp1/
19320       allocate(mu(2,nres))
19321       allocate(muder(2,nres))
19322       allocate(Ub2(2,nres))
19323       Ub2(1,:)=0.0d0
19324       Ub2(2,:)=0.0d0
19325       allocate(Ub2der(2,nres))
19326       allocate(Ctobr(2,nres))
19327       allocate(Ctobrder(2,nres))
19328       allocate(Dtobr2(2,nres))
19329       allocate(Dtobr2der(2,nres))
19330 !(2,maxres)
19331       allocate(EUg(2,2,nres))
19332       allocate(EUgder(2,2,nres))
19333       allocate(CUg(2,2,nres))
19334       allocate(CUgder(2,2,nres))
19335       allocate(DUg(2,2,nres))
19336       allocate(Dugder(2,2,nres))
19337       allocate(DtUg2(2,2,nres))
19338       allocate(DtUg2der(2,2,nres))
19339 !(2,2,maxres)
19340 !      common /precomp2/
19341       allocate(Ug2Db1t(2,nres))
19342       allocate(Ug2Db1tder(2,nres))
19343       allocate(CUgb2(2,nres))
19344       allocate(CUgb2der(2,nres))
19345 !(2,maxres)
19346       allocate(EUgC(2,2,nres))
19347       allocate(EUgCder(2,2,nres))
19348       allocate(EUgD(2,2,nres))
19349       allocate(EUgDder(2,2,nres))
19350       allocate(DtUg2EUg(2,2,nres))
19351       allocate(Ug2DtEUg(2,2,nres))
19352 !(2,2,maxres)
19353       allocate(Ug2DtEUgder(2,2,2,nres))
19354       allocate(DtUg2EUgder(2,2,2,nres))
19355 !(2,2,2,maxres)
19356 !      common /rotat_old/
19357       allocate(costab(nres))
19358       allocate(sintab(nres))
19359       allocate(costab2(nres))
19360       allocate(sintab2(nres))
19361 !(maxres)
19362 !      common /dipmat/
19363       allocate(a_chuj(2,2,maxconts,nres))
19364 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19365       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19366 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19367 !      common /contdistrib/
19368       allocate(ncont_sent(nres))
19369       allocate(ncont_recv(nres))
19370
19371       allocate(iat_sent(nres))
19372 !(maxres)
19373       allocate(iint_sent(4,nres,nres))
19374       allocate(iint_sent_local(4,nres,nres))
19375 !(4,maxres,maxres)
19376       allocate(iturn3_sent(4,0:nres+4))
19377       allocate(iturn4_sent(4,0:nres+4))
19378       allocate(iturn3_sent_local(4,nres))
19379       allocate(iturn4_sent_local(4,nres))
19380 !(4,maxres)
19381       allocate(itask_cont_from(0:nfgtasks-1))
19382       allocate(itask_cont_to(0:nfgtasks-1))
19383 !(0:max_fg_procs-1)
19384
19385
19386
19387 !----------------------
19388 ! commom.deriv;
19389 !      common /derivat/
19390       allocate(dcdv(6,maxdim))
19391       allocate(dxdv(6,maxdim))
19392 !(6,maxdim)
19393       allocate(dxds(6,nres))
19394 !(6,maxres)
19395       allocate(gradx(3,-1:nres,0:2))
19396       allocate(gradc(3,-1:nres,0:2))
19397 !(3,maxres,2)
19398       allocate(gvdwx(3,-1:nres))
19399       allocate(gvdwc(3,-1:nres))
19400       allocate(gelc(3,-1:nres))
19401       allocate(gelc_long(3,-1:nres))
19402       allocate(gvdwpp(3,-1:nres))
19403       allocate(gvdwc_scpp(3,-1:nres))
19404       allocate(gradx_scp(3,-1:nres))
19405       allocate(gvdwc_scp(3,-1:nres))
19406       allocate(ghpbx(3,-1:nres))
19407       allocate(ghpbc(3,-1:nres))
19408       allocate(gradcorr(3,-1:nres))
19409       allocate(gradcorr_long(3,-1:nres))
19410       allocate(gradcorr5_long(3,-1:nres))
19411       allocate(gradcorr6_long(3,-1:nres))
19412       allocate(gcorr6_turn_long(3,-1:nres))
19413       allocate(gradxorr(3,-1:nres))
19414       allocate(gradcorr5(3,-1:nres))
19415       allocate(gradcorr6(3,-1:nres))
19416       allocate(gliptran(3,-1:nres))
19417       allocate(gliptranc(3,-1:nres))
19418       allocate(gliptranx(3,-1:nres))
19419       allocate(gshieldx(3,-1:nres))
19420       allocate(gshieldc(3,-1:nres))
19421       allocate(gshieldc_loc(3,-1:nres))
19422       allocate(gshieldx_ec(3,-1:nres))
19423       allocate(gshieldc_ec(3,-1:nres))
19424       allocate(gshieldc_loc_ec(3,-1:nres))
19425       allocate(gshieldx_t3(3,-1:nres))
19426       allocate(gshieldc_t3(3,-1:nres))
19427       allocate(gshieldc_loc_t3(3,-1:nres))
19428       allocate(gshieldx_t4(3,-1:nres))
19429       allocate(gshieldc_t4(3,-1:nres))
19430       allocate(gshieldc_loc_t4(3,-1:nres))
19431       allocate(gshieldx_ll(3,-1:nres))
19432       allocate(gshieldc_ll(3,-1:nres))
19433       allocate(gshieldc_loc_ll(3,-1:nres))
19434       allocate(grad_shield(3,-1:nres))
19435       allocate(gg_tube_sc(3,-1:nres))
19436       allocate(gg_tube(3,-1:nres))
19437       allocate(gradafm(3,-1:nres))
19438 !(3,maxres)
19439       allocate(grad_shield_side(3,50,nres))
19440       allocate(grad_shield_loc(3,50,nres))
19441 ! grad for shielding surroing
19442       allocate(gloc(0:maxvar,0:2))
19443       allocate(gloc_x(0:maxvar,2))
19444 !(maxvar,2)
19445       allocate(gel_loc(3,-1:nres))
19446       allocate(gel_loc_long(3,-1:nres))
19447       allocate(gcorr3_turn(3,-1:nres))
19448       allocate(gcorr4_turn(3,-1:nres))
19449       allocate(gcorr6_turn(3,-1:nres))
19450       allocate(gradb(3,-1:nres))
19451       allocate(gradbx(3,-1:nres))
19452 !(3,maxres)
19453       allocate(gel_loc_loc(maxvar))
19454       allocate(gel_loc_turn3(maxvar))
19455       allocate(gel_loc_turn4(maxvar))
19456       allocate(gel_loc_turn6(maxvar))
19457       allocate(gcorr_loc(maxvar))
19458       allocate(g_corr5_loc(maxvar))
19459       allocate(g_corr6_loc(maxvar))
19460 !(maxvar)
19461       allocate(gsccorc(3,-1:nres))
19462       allocate(gsccorx(3,-1:nres))
19463 !(3,maxres)
19464       allocate(gsccor_loc(-1:nres))
19465 !(maxres)
19466       allocate(dtheta(3,2,-1:nres))
19467 !(3,2,maxres)
19468       allocate(gscloc(3,-1:nres))
19469       allocate(gsclocx(3,-1:nres))
19470 !(3,maxres)
19471       allocate(dphi(3,3,-1:nres))
19472       allocate(dalpha(3,3,-1:nres))
19473       allocate(domega(3,3,-1:nres))
19474 !(3,3,maxres)
19475 !      common /deriv_scloc/
19476       allocate(dXX_C1tab(3,nres))
19477       allocate(dYY_C1tab(3,nres))
19478       allocate(dZZ_C1tab(3,nres))
19479       allocate(dXX_Ctab(3,nres))
19480       allocate(dYY_Ctab(3,nres))
19481       allocate(dZZ_Ctab(3,nres))
19482       allocate(dXX_XYZtab(3,nres))
19483       allocate(dYY_XYZtab(3,nres))
19484       allocate(dZZ_XYZtab(3,nres))
19485 !(3,maxres)
19486 !      common /mpgrad/
19487       allocate(jgrad_start(nres))
19488       allocate(jgrad_end(nres))
19489 !(maxres)
19490 !----------------------
19491
19492 !      common /indices/
19493       allocate(ibond_displ(0:nfgtasks-1))
19494       allocate(ibond_count(0:nfgtasks-1))
19495       allocate(ithet_displ(0:nfgtasks-1))
19496       allocate(ithet_count(0:nfgtasks-1))
19497       allocate(iphi_displ(0:nfgtasks-1))
19498       allocate(iphi_count(0:nfgtasks-1))
19499       allocate(iphi1_displ(0:nfgtasks-1))
19500       allocate(iphi1_count(0:nfgtasks-1))
19501       allocate(ivec_displ(0:nfgtasks-1))
19502       allocate(ivec_count(0:nfgtasks-1))
19503       allocate(iset_displ(0:nfgtasks-1))
19504       allocate(iset_count(0:nfgtasks-1))
19505       allocate(iint_count(0:nfgtasks-1))
19506       allocate(iint_displ(0:nfgtasks-1))
19507 !(0:max_fg_procs-1)
19508 !----------------------
19509 ! common.MD
19510 !      common /mdgrad/
19511       allocate(gcart(3,-1:nres))
19512       allocate(gxcart(3,-1:nres))
19513 !(3,0:MAXRES)
19514       allocate(gradcag(3,-1:nres))
19515       allocate(gradxag(3,-1:nres))
19516 !(3,MAXRES)
19517 !      common /back_constr/
19518 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19519       allocate(dutheta(nres))
19520       allocate(dugamma(nres))
19521 !(maxres)
19522       allocate(duscdiff(3,nres))
19523       allocate(duscdiffx(3,nres))
19524 !(3,maxres)
19525 !el i io:read_fragments
19526 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19527 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19528 !      common /qmeas/
19529 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19530 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19531       allocate(mset(0:nprocs))  !(maxprocs/20)
19532       mset(:)=0
19533 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19534 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19535       allocate(dUdconst(3,0:nres))
19536       allocate(dUdxconst(3,0:nres))
19537       allocate(dqwol(3,0:nres))
19538       allocate(dxqwol(3,0:nres))
19539 !(3,0:MAXRES)
19540 !----------------------
19541 ! common.sbridge
19542 !      common /sbridge/ in io_common: read_bridge
19543 !el    allocate((:),allocatable :: iss  !(maxss)
19544 !      common /links/  in io_common: read_bridge
19545 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19546 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19547 !      common /dyn_ssbond/
19548 ! and side-chain vectors in theta or phi.
19549       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19550 !(maxres,maxres)
19551 !      do i=1,nres
19552 !        do j=i+1,nres
19553       dyn_ssbond_ij(:,:)=1.0d300
19554 !        enddo
19555 !      enddo
19556
19557 !      if (nss.gt.0) then
19558         allocate(idssb(maxdim),jdssb(maxdim))
19559 !        allocate(newihpb(nss),newjhpb(nss))
19560 !(maxdim)
19561 !      endif
19562       allocate(ishield_list(nres))
19563       allocate(shield_list(50,nres))
19564       allocate(dyn_ss_mask(nres))
19565       allocate(fac_shield(nres))
19566       allocate(enetube(nres*2))
19567       allocate(enecavtube(nres*2))
19568
19569 !(maxres)
19570       dyn_ss_mask(:)=.false.
19571 !----------------------
19572 ! common.sccor
19573 ! Parameters of the SCCOR term
19574 !      common/sccor/
19575 !el in io_conf: parmread
19576 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
19577 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
19578 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
19579 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
19580 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
19581 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
19582 !      allocate(vlor1sccor(maxterm_sccor,20,20))
19583 !      allocate(vlor2sccor(maxterm_sccor,20,20))
19584 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
19585 !----------------
19586       allocate(gloc_sc(3,0:2*nres,0:10))
19587 !(3,0:maxres2,10)maxres2=2*maxres
19588       allocate(dcostau(3,3,3,2*nres))
19589       allocate(dsintau(3,3,3,2*nres))
19590       allocate(dtauangle(3,3,3,2*nres))
19591       allocate(dcosomicron(3,3,3,2*nres))
19592       allocate(domicron(3,3,3,2*nres))
19593 !(3,3,3,maxres2)maxres2=2*maxres
19594 !----------------------
19595 ! common.var
19596 !      common /restr/
19597       allocate(varall(maxvar))
19598 !(maxvar)(maxvar=6*maxres)
19599       allocate(mask_theta(nres))
19600       allocate(mask_phi(nres))
19601       allocate(mask_side(nres))
19602 !(maxres)
19603 !----------------------
19604 ! common.vectors
19605 !      common /vectors/
19606       allocate(uy(3,nres))
19607       allocate(uz(3,nres))
19608 !(3,maxres)
19609       allocate(uygrad(3,3,2,nres))
19610       allocate(uzgrad(3,3,2,nres))
19611 !(3,3,2,maxres)
19612
19613       return
19614       end subroutine alloc_ener_arrays
19615 !-----------------------------------------------------------------------------
19616 !-----------------------------------------------------------------------------
19617       end module energy