source/unres/energy.f90

   1       module energy
   2 !-----------------------------------------------------------------------------
   3       use io_units
   4       use names
   5       use math
   6       use MPI_data
   7       use energy_data
   8       use control_data
   9       use geometry_data
  10       use geometry
  11 !
  12       implicit none
  13 !-----------------------------------------------------------------------------
  14 ! Max. number of contacts per residue
  15 !      integer :: maxconts
  16 !-----------------------------------------------------------------------------
  17 ! Max. number of derivatives of virtual-bond and side-chain vectors in theta
  18 ! or phi.
  19 !      integer :: maxdim
  20 !-----------------------------------------------------------------------------
  21 ! Max. number of SC contacts
  22 !      integer :: maxcont
  23 !-----------------------------------------------------------------------------
  24 ! Max. number of variables
  25       integer :: maxvar
  26 !-----------------------------------------------------------------------------
  27 ! Max number of torsional terms in SCCOR  in control_data
  28 !      integer,parameter :: maxterm_sccor=6
  29 !-----------------------------------------------------------------------------
  30 ! Maximum number of SC local term fitting function coefficiants
  31       integer,parameter :: maxsccoef=65
  32 ! Maximum number of local shielding effectors
  33       integer,parameter :: maxcontsshi=50
  34 !-----------------------------------------------------------------------------
  35 ! commom.calc common/calc/
  36 !-----------------------------------------------------------------------------
  37 ! commom.contacts
  38 !      common /contacts/
  39 ! Change 12/1/95 - common block CONTACTS1 included.
  40 !      common /contacts1/
  41
  42       integer,dimension(:),allocatable :: num_cont      !(maxres)
  43       integer,dimension(:,:),allocatable :: jcont       !(maxconts,maxres)
  44       real(kind=8),dimension(:,:),allocatable :: facont,ees0plist       !(maxconts,maxres)
  45       real(kind=8),dimension(:,:,:),allocatable :: gacont       !(3,maxconts,maxres)
  46       integer,dimension(:),allocatable :: ishield_list
  47       integer,dimension(:,:),allocatable ::  shield_list
  48 !
  49 ! 12/26/95 - H-bonding contacts
  50 !      common /contacts_hb/
  51       real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,&
  52        gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont  !(3,maxconts,maxres)
  53       real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,&
  54         ees0m,d_cont    !(maxconts,maxres)
  55       integer,dimension(:),allocatable :: num_cont_hb   !(maxres)
  56       integer,dimension(:,:),allocatable :: jcont_hb    !(maxconts,maxres)
  57 ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
  58 !         interactions
  59 ! 7/25/08 commented out; not needed when cumulants used
  60 ! Interactions of pseudo-dipoles generated by loc-el interactions.
  61 !  common /dipint/
  62       real(kind=8),dimension(:,:,:),allocatable :: dip,&
  63          dipderg        !(4,maxconts,maxres)
  64       real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres)
  65 ! 10/30/99 Added other pre-computed vectors and matrices needed
  66 !          to calculate three - six-order el-loc correlation terms
  67 ! common /rotat/
  68       real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der  !(2,2,maxres)
  69       real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,&
  70        obrot2_der       !(2,maxres)
  71 !
  72 ! This common block contains vectors and matrices dependent on a single
  73 ! amino-acid residue.
  74 !      common /precomp1/
  75       real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,&
  76        Ctobr,Ctobrder,Dtobr2,Dtobr2der  !(2,maxres)
  77       real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,&
  78        CUgder,DUg,Dugder,DtUg2,DtUg2der !(2,2,maxres)
  79 ! This common block contains vectors and matrices dependent on two
  80 ! consecutive amino-acid residues.
  81 !      common /precomp2/
  82       real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,&
  83        CUgb2,CUgb2der   !(2,maxres)
  84       real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,&
  85        EUgD,EUgDder,DtUg2EUg,Ug2DtEUg   !(2,2,maxres)
  86       real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,&
  87        DtUg2EUgder      !(2,2,2,maxres)
  88 !      common /rotat_old/
  89       real(kind=8),dimension(:),allocatable :: costab,sintab,&
  90        costab2,sintab2  !(maxres)
  91 ! This common block contains dipole-interaction matrices and their
  92 ! Cartesian derivatives.
  93 !      common /dipmat/
  94       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj     !(2,2,maxconts,maxres)
  95       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der     !(2,2,3,5,maxconts,maxres)
  96 !      common /diploc/
  97       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
  98        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
  99       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
 100        ADtEA1derg,AEAb2derg
 101       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
 102        AECAderx,ADtEAderx,ADtEA1derx
 103       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
 104       real(kind=8),dimension(3,2) :: g_contij
 105       real(kind=8) :: ekont
 106 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 107 !   RE: Parallelization of 4th and higher order loc-el correlations
 108 !      common /contdistrib/
 109       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 110 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 111 !-----------------------------------------------------------------------------
 112 ! commom.deriv;
 113 !      common /derivat/
 114 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 115 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 116 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 117       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 118         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 119         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 120         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6,gliptran,gliptranc,&
 121         gliptranx, &
 122         gshieldx,gshieldc,gshieldc_loc,gshieldx_ec,&
 123         gshieldc_ec,gshieldc_loc_ec,gshieldx_t3, &
 124         gshieldc_t3,gshieldc_loc_t3,gshieldx_t4,gshieldc_t4, &
 125         gshieldc_loc_t4,gshieldx_ll,gshieldc_ll,gshieldc_loc_ll,&
 126         grad_shield !(3,maxres)
 127 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 128       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 129         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 130       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 131         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 132         g_corr6_loc     !(maxvar)
 133       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 134       real(kind=8),dimension(:),allocatable :: gsccor_loc       !(maxres)
 135 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 136       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 137 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 138       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 139          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 140 !      integer :: nfl,icg
 141 !      common /deriv_loc/
 142       real(kind=8), dimension(:),allocatable :: fac_shield
 143       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 144 !      common /deriv_scloc/
 145       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 146        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 147        dZZ_XYZtab       !(3,maxres)
 148 !-----------------------------------------------------------------------------
 149 ! common.maxgrad
 150 !      common /maxgrad/
 151       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 152        gradb_max,ghpbc_max,&
 153        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 154        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 155        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 156        gsccorx_max,gsclocx_max
 157 !-----------------------------------------------------------------------------
 158 ! common.MD
 159 !      common /back_constr/
 160       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 161       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 162 !      common /qmeas/
 163       real(kind=8) :: Ucdfrag,Ucdpair
 164       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 165        dqwol,dxqwol     !(3,0:MAXRES)
 166 !-----------------------------------------------------------------------------
 167 ! common.sbridge
 168 !      common /dyn_ssbond/
 169       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 170 !-----------------------------------------------------------------------------
 171 ! common.sccor
 172 ! Parameters of the SCCOR term
 173 !      common/sccor/
 174       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 175        dcosomicron,domicron     !(3,3,3,maxres2)
 176 !-----------------------------------------------------------------------------
 177 ! common.vectors
 178 !      common /vectors/
 179       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 180       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 181 !-----------------------------------------------------------------------------
 182 ! common /przechowalnia/
 183       real(kind=8),dimension(:,:,:),allocatable :: zapas !(max_dim,maxconts,max_fg_procs)
 184       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 185 !-----------------------------------------------------------------------------
 186 !-----------------------------------------------------------------------------
 187 !
 188 !
 189 !-----------------------------------------------------------------------------
 190       contains
 191 !-----------------------------------------------------------------------------
 192 ! energy_p_new_barrier.F
 193 !-----------------------------------------------------------------------------
 194       subroutine etotal(energia)
 195 !      implicit real*8 (a-h,o-z)
 196 !      include 'DIMENSIONS'
 197       use MD_data
 198 #ifndef ISNAN
 199       external proc_proc
 200 #ifdef WINPGI
 201 !MS$ATTRIBUTES C ::  proc_proc
 202 #endif
 203 #endif
 204 #ifdef MPI
 205       include "mpif.h"
 206 #endif
 207 !      include 'COMMON.SETUP'
 208 !      include 'COMMON.IOUNITS'
 209       real(kind=8),dimension(0:n_ene) :: energia
 210 !      include 'COMMON.LOCAL'
 211 !      include 'COMMON.FFIELD'
 212 !      include 'COMMON.DERIV'
 213 !      include 'COMMON.INTERACT'
 214 !      include 'COMMON.SBRIDGE'
 215 !      include 'COMMON.CHAIN'
 216 !      include 'COMMON.VAR'
 217 !      include 'COMMON.MD'
 218 !      include 'COMMON.CONTROL'
 219 !      include 'COMMON.TIME1'
 220       real(kind=8) :: time00
 221 !el local variables
 222       integer :: n_corr,n_corr1,ierror
 223       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 224       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 225       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran
 226       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 227
 228 #ifdef MPI
 229       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 230 ! shielding effect varibles for MPI
 231 !      real(kind=8)   fac_shieldbuf(maxres),
 232 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 233 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 234 !     & grad_shieldbuf(3,-1:maxres)
 235 !       integer ishield_listbuf(maxres),
 236 !     &shield_listbuf(maxcontsshi,maxres)
 237
 238 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 239 !     & " nfgtasks",nfgtasks
 240       if (nfgtasks.gt.1) then
 241         time00=MPI_Wtime()
 242 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 243         if (fg_rank.eq.0) then
 244           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 245 !          print *,"Processor",myrank," BROADCAST iorder"
 246 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 247 ! FG slaves as WEIGHTS array.
 248           weights_(1)=wsc
 249           weights_(2)=wscp
 250           weights_(3)=welec
 251           weights_(4)=wcorr
 252           weights_(5)=wcorr5
 253           weights_(6)=wcorr6
 254           weights_(7)=wel_loc
 255           weights_(8)=wturn3
 256           weights_(9)=wturn4
 257           weights_(10)=wturn6
 258           weights_(11)=wang
 259           weights_(12)=wscloc
 260           weights_(13)=wtor
 261           weights_(14)=wtor_d
 262           weights_(15)=wstrain
 263           weights_(16)=wvdwpp
 264           weights_(17)=wbond
 265           weights_(18)=scal14
 266           weights_(21)=wsccor
 267 ! FG Master broadcasts the WEIGHTS_ array
 268           call MPI_Bcast(weights_(1),n_ene,&
 269              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 270         else
 271 ! FG slaves receive the WEIGHTS array
 272           call MPI_Bcast(weights(1),n_ene,&
 273               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 274           wsc=weights(1)
 275           wscp=weights(2)
 276           welec=weights(3)
 277           wcorr=weights(4)
 278           wcorr5=weights(5)
 279           wcorr6=weights(6)
 280           wel_loc=weights(7)
 281           wturn3=weights(8)
 282           wturn4=weights(9)
 283           wturn6=weights(10)
 284           wang=weights(11)
 285           wscloc=weights(12)
 286           wtor=weights(13)
 287           wtor_d=weights(14)
 288           wstrain=weights(15)
 289           wvdwpp=weights(16)
 290           wbond=weights(17)
 291           scal14=weights(18)
 292           wsccor=weights(21)
 293         endif
 294         time_Bcast=time_Bcast+MPI_Wtime()-time00
 295         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 296 !        call chainbuild_cart
 297       endif
 298 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 299 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 300 #else
 301 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 302 !        call int_from_cart1(.false.)
 303 !      endif
 304 #endif
 305 #ifdef TIMING
 306       time00=MPI_Wtime()
 307 #endif
 308 !
 309 ! Compute the side-chain and electrostatic interaction energy
 310         print *, "Before EVDW"
 311 !      goto (101,102,103,104,105,106) ipot
 312       select case(ipot)
 313 ! Lennard-Jones potential.
 314 !  101 call elj(evdw)
 315        case (1)
 316          call elj(evdw)
 317 !d    print '(a)','Exit ELJcall el'
 318 !      goto 107
 319 ! Lennard-Jones-Kihara potential (shifted).
 320 !  102 call eljk(evdw)
 321        case (2)
 322          call eljk(evdw)
 323 !      goto 107
 324 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 325 !  103 call ebp(evdw)
 326        case (3)
 327          call ebp(evdw)
 328 !      goto 107
 329 ! Gay-Berne potential (shifted LJ, angular dependence).
 330 !  104 call egb(evdw)
 331        case (4)
 332          call egb(evdw)
 333 !      goto 107
 334 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 335 !  105 call egbv(evdw)
 336        case (5)
 337          call egbv(evdw)
 338 !      goto 107
 339 ! Soft-sphere potential
 340 !  106 call e_softsphere(evdw)
 341        case (6)
 342          call e_softsphere(evdw)
 343 !
 344 ! Calculate electrostatic (H-bonding) energy of the main chain.
 345 !
 346 !  107 continue
 347        case default
 348          write(iout,*)"Wrong ipot"
 349 !         return
 350 !   50 continue
 351       end select
 352 !      continue
 353 !        print *,"after EGB"
 354 ! shielding effect
 355        if (shield_mode.eq.2) then
 356                  call set_shield_fac2
 357        endif
 358 !mc
 359 !mc Sep-06: egb takes care of dynamic ss bonds too
 360 !mc
 361 !      if (dyn_ss) call dyn_set_nss
 362 !      print *,"Processor",myrank," computed USCSC"
 363 #ifdef TIMING
 364       time01=MPI_Wtime()
 365 #endif
 366       call vec_and_deriv
 367 #ifdef TIMING
 368       time_vec=time_vec+MPI_Wtime()-time01
 369 #endif
 370 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 371       if (ipot.lt.6) then
 372 #ifdef SPLITELE
 373          print *,"after ipot if", ipot
 374          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 375              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 376              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 377              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 378 #else
 379          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 380              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 381              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 382              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 383 #endif
 384 !            print *,"just befor eelec call"
 385             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 386 !         write (iout,*) "ELEC calc"
 387          else
 388             ees=0.0d0
 389             evdw1=0.0d0
 390             eel_loc=0.0d0
 391             eello_turn3=0.0d0
 392             eello_turn4=0.0d0
 393          endif
 394       else
 395 !        write (iout,*) "Soft-spheer ELEC potential"
 396         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 397          eello_turn4)
 398       endif
 399 !      print *,"Processor",myrank," computed UELEC"
 400 !
 401 ! Calculate excluded-volume interaction energy between peptide groups
 402 ! and side chains.
 403 !
 404 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 405
 406       if (ipot.lt.6) then
 407        if(wscp.gt.0d0) then
 408         call escp(evdw2,evdw2_14)
 409        else
 410         evdw2=0
 411         evdw2_14=0
 412        endif
 413       else
 414 !        write (iout,*) "Soft-sphere SCP potential"
 415         call escp_soft_sphere(evdw2,evdw2_14)
 416       endif
 417 !       write(iout,*) "in etotal before ebond",ipot
 418
 419 !
 420 ! Calculate the bond-stretching energy
 421 !
 422       call ebond(estr)
 423 !       write(iout,*) "in etotal afer ebond",ipot
 424
 425 !
 426 ! Calculate the disulfide-bridge and other energy and the contributions
 427 ! from other distance constraints.
 428 !      print *,'Calling EHPB'
 429       call edis(ehpb)
 430 !elwrite(iout,*) "in etotal afer edis",ipot
 431 !      print *,'EHPB exitted succesfully.'
 432 !
 433 ! Calculate the virtual-bond-angle energy.
 434 !
 435       if (wang.gt.0d0) then
 436         call ebend(ebe)
 437       else
 438         ebe=0
 439       endif
 440 !      print *,"Processor",myrank," computed UB"
 441 !
 442 ! Calculate the SC local energy.
 443 !
 444       call esc(escloc)
 445 !elwrite(iout,*) "in etotal afer esc",ipot
 446 !      print *,"Processor",myrank," computed USC"
 447 !
 448 ! Calculate the virtual-bond torsional energy.
 449 !
 450 !d    print *,'nterm=',nterm
 451       if (wtor.gt.0) then
 452        call etor(etors,edihcnstr)
 453       else
 454        etors=0
 455        edihcnstr=0
 456       endif
 457 !      print *,"Processor",myrank," computed Utor"
 458 !
 459 ! 6/23/01 Calculate double-torsional energy
 460 !
 461 !elwrite(iout,*) "in etotal",ipot
 462       if (wtor_d.gt.0) then
 463        call etor_d(etors_d)
 464       else
 465        etors_d=0
 466       endif
 467 !      print *,"Processor",myrank," computed Utord"
 468 !
 469 ! 21/5/07 Calculate local sicdechain correlation energy
 470 !
 471       if (wsccor.gt.0.0d0) then
 472         call eback_sc_corr(esccor)
 473       else
 474         esccor=0.0d0
 475       endif
 476 !      print *,"Processor",myrank," computed Usccorr"
 477 !
 478 ! 12/1/95 Multi-body terms
 479 !
 480       n_corr=0
 481       n_corr1=0
 482       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 483           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 484          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 485 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 486 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 487       else
 488          ecorr=0.0d0
 489          ecorr5=0.0d0
 490          ecorr6=0.0d0
 491          eturn6=0.0d0
 492       endif
 493 !elwrite(iout,*) "in etotal",ipot
 494       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 495          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 496 !d         write (iout,*) "multibody_hb ecorr",ecorr
 497       endif
 498 !elwrite(iout,*) "afeter  multibody hb"
 499
 500 !      print *,"Processor",myrank," computed Ucorr"
 501 !
 502 ! If performing constraint dynamics, call the constraint energy
 503 !  after the equilibration time
 504       if(usampl.and.totT.gt.eq_time) then
 505 !elwrite(iout,*) "afeter  multibody hb"
 506          call EconstrQ
 507 !elwrite(iout,*) "afeter  multibody hb"
 508          call Econstr_back
 509 !elwrite(iout,*) "afeter  multibody hb"
 510       else
 511          Uconst=0.0d0
 512          Uconst_back=0.0d0
 513       endif
 514       call flush(iout)
 515 !         write(iout,*) "after Econstr"
 516
 517       if (wliptran.gt.0) then
 518 !        print *,"PRZED WYWOLANIEM"
 519         call Eliptransfer(eliptran)
 520       else
 521        eliptran=0.0d0
 522       endif
 523
 524 #ifdef TIMING
 525       time_enecalc=time_enecalc+MPI_Wtime()-time00
 526 #endif
 527 !      print *,"Processor",myrank," computed Uconstr"
 528 #ifdef TIMING
 529       time00=MPI_Wtime()
 530 #endif
 531 !
 532 ! Sum the energies
 533 !
 534       energia(1)=evdw
 535 #ifdef SCP14
 536       energia(2)=evdw2-evdw2_14
 537       energia(18)=evdw2_14
 538 #else
 539       energia(2)=evdw2
 540       energia(18)=0.0d0
 541 #endif
 542 #ifdef SPLITELE
 543       energia(3)=ees
 544       energia(16)=evdw1
 545 #else
 546       energia(3)=ees+evdw1
 547       energia(16)=0.0d0
 548 #endif
 549       energia(4)=ecorr
 550       energia(5)=ecorr5
 551       energia(6)=ecorr6
 552       energia(7)=eel_loc
 553       energia(8)=eello_turn3
 554       energia(9)=eello_turn4
 555       energia(10)=eturn6
 556       energia(11)=ebe
 557       energia(12)=escloc
 558       energia(13)=etors
 559       energia(14)=etors_d
 560       energia(15)=ehpb
 561       energia(19)=edihcnstr
 562       energia(17)=estr
 563       energia(20)=Uconst+Uconst_back
 564       energia(21)=esccor
 565       energia(22)=eliptran
 566 !    Here are the energies showed per procesor if the are more processors
 567 !    per molecule then we sum it up in sum_energy subroutine
 568 !      print *," Processor",myrank," calls SUM_ENERGY"
 569       call sum_energy(energia,.true.)
 570       if (dyn_ss) call dyn_set_nss
 571 !      print *," Processor",myrank," left SUM_ENERGY"
 572 #ifdef TIMING
 573       time_sumene=time_sumene+MPI_Wtime()-time00
 574 #endif
 575 !el        call enerprint(energia)
 576 !elwrite(iout,*)"finish etotal"
 577       return
 578       end subroutine etotal
 579 !-----------------------------------------------------------------------------
 580       subroutine sum_energy(energia,reduce)
 581 !      implicit real*8 (a-h,o-z)
 582 !      include 'DIMENSIONS'
 583 #ifndef ISNAN
 584       external proc_proc
 585 #ifdef WINPGI
 586 !MS$ATTRIBUTES C ::  proc_proc
 587 #endif
 588 #endif
 589 #ifdef MPI
 590       include "mpif.h"
 591 #endif
 592 !      include 'COMMON.SETUP'
 593 !      include 'COMMON.IOUNITS'
 594       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 595 !      include 'COMMON.FFIELD'
 596 !      include 'COMMON.DERIV'
 597 !      include 'COMMON.INTERACT'
 598 !      include 'COMMON.SBRIDGE'
 599 !      include 'COMMON.CHAIN'
 600 !      include 'COMMON.VAR'
 601 !      include 'COMMON.CONTROL'
 602 !      include 'COMMON.TIME1'
 603       logical :: reduce
 604       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 605       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 606       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 607         eliptran
 608       integer :: i
 609 #ifdef MPI
 610       integer :: ierr
 611       real(kind=8) :: time00
 612       if (nfgtasks.gt.1 .and. reduce) then
 613
 614 #ifdef DEBUG
 615         write (iout,*) "energies before REDUCE"
 616         call enerprint(energia)
 617         call flush(iout)
 618 #endif
 619         do i=0,n_ene
 620           enebuff(i)=energia(i)
 621         enddo
 622         time00=MPI_Wtime()
 623         call MPI_Barrier(FG_COMM,IERR)
 624         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 625         time00=MPI_Wtime()
 626         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 627           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 628 #ifdef DEBUG
 629         write (iout,*) "energies after REDUCE"
 630         call enerprint(energia)
 631         call flush(iout)
 632 #endif
 633         time_Reduce=time_Reduce+MPI_Wtime()-time00
 634       endif
 635       if (fg_rank.eq.0) then
 636 #endif
 637       evdw=energia(1)
 638 #ifdef SCP14
 639       evdw2=energia(2)+energia(18)
 640       evdw2_14=energia(18)
 641 #else
 642       evdw2=energia(2)
 643 #endif
 644 #ifdef SPLITELE
 645       ees=energia(3)
 646       evdw1=energia(16)
 647 #else
 648       ees=energia(3)
 649       evdw1=0.0d0
 650 #endif
 651       ecorr=energia(4)
 652       ecorr5=energia(5)
 653       ecorr6=energia(6)
 654       eel_loc=energia(7)
 655       eello_turn3=energia(8)
 656       eello_turn4=energia(9)
 657       eturn6=energia(10)
 658       ebe=energia(11)
 659       escloc=energia(12)
 660       etors=energia(13)
 661       etors_d=energia(14)
 662       ehpb=energia(15)
 663       edihcnstr=energia(19)
 664       estr=energia(17)
 665       Uconst=energia(20)
 666       esccor=energia(21)
 667       eliptran=energia(22)
 668 #ifdef SPLITELE
 669       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 670        +wang*ebe+wtor*etors+wscloc*escloc &
 671        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 672        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 673        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 674        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 675 #else
 676       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 677        +wang*ebe+wtor*etors+wscloc*escloc &
 678        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 679        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 680        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 681        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 682 #endif
 683       energia(0)=etot
 684 ! detecting NaNQ
 685 #ifdef ISNAN
 686 #ifdef AIX
 687       if (isnan(etot).ne.0) energia(0)=1.0d+99
 688 #else
 689       if (isnan(etot)) energia(0)=1.0d+99
 690 #endif
 691 #else
 692       i=0
 693 #ifdef WINPGI
 694       idumm=proc_proc(etot,i)
 695 #else
 696       call proc_proc(etot,i)
 697 #endif
 698       if(i.eq.1)energia(0)=1.0d+99
 699 #endif
 700 #ifdef MPI
 701       endif
 702 #endif
 703 !      call enerprint(energia)
 704       call flush(iout)
 705       return
 706       end subroutine sum_energy
 707 !-----------------------------------------------------------------------------
 708       subroutine rescale_weights(t_bath)
 709 !      implicit real*8 (a-h,o-z)
 710 #ifdef MPI
 711       include 'mpif.h'
 712 #endif
 713 !      include 'DIMENSIONS'
 714 !      include 'COMMON.IOUNITS'
 715 !      include 'COMMON.FFIELD'
 716 !      include 'COMMON.SBRIDGE'
 717       real(kind=8) :: kfac=2.4d0
 718       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 719 !el local variables
 720       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 721       real(kind=8) :: T0=3.0d2
 722       integer :: ierror
 723 !      facT=temp0/t_bath
 724 !      facT=2*temp0/(t_bath+temp0)
 725       if (rescale_mode.eq.0) then
 726         facT(1)=1.0d0
 727         facT(2)=1.0d0
 728         facT(3)=1.0d0
 729         facT(4)=1.0d0
 730         facT(5)=1.0d0
 731         facT(6)=1.0d0
 732       else if (rescale_mode.eq.1) then
 733         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 734         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 735         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 736         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 737         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 738 #ifdef WHAM_RUN
 739 !#if defined(WHAM_RUN) || defined(CLUSTER)
 740 #if defined(FUNCTH)
 741 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 742         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 743 #elif defined(FUNCT)
 744         facT(6)=t_bath/T0
 745 #else
 746         facT(6)=1.0d0
 747 #endif
 748 #endif
 749       else if (rescale_mode.eq.2) then
 750         x=t_bath/temp0
 751         x2=x*x
 752         x3=x2*x
 753         x4=x3*x
 754         x5=x4*x
 755         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 756         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 757         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 758         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 759         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 760 #ifdef WHAM_RUN
 761 !#if defined(WHAM_RUN) || defined(CLUSTER)
 762 #if defined(FUNCTH)
 763         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 764 #elif defined(FUNCT)
 765         facT(6)=t_bath/T0
 766 #else
 767         facT(6)=1.0d0
 768 #endif
 769 #endif
 770       else
 771         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 772         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 773 #ifdef MPI
 774        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 775 #endif
 776        stop 555
 777       endif
 778       welec=weights(3)*fact(1)
 779       wcorr=weights(4)*fact(3)
 780       wcorr5=weights(5)*fact(4)
 781       wcorr6=weights(6)*fact(5)
 782       wel_loc=weights(7)*fact(2)
 783       wturn3=weights(8)*fact(2)
 784       wturn4=weights(9)*fact(3)
 785       wturn6=weights(10)*fact(5)
 786       wtor=weights(13)*fact(1)
 787       wtor_d=weights(14)*fact(2)
 788       wsccor=weights(21)*fact(1)
 789
 790       return
 791       end subroutine rescale_weights
 792 !-----------------------------------------------------------------------------
 793       subroutine enerprint(energia)
 794 !      implicit real*8 (a-h,o-z)
 795 !      include 'DIMENSIONS'
 796 !      include 'COMMON.IOUNITS'
 797 !      include 'COMMON.FFIELD'
 798 !      include 'COMMON.SBRIDGE'
 799 !      include 'COMMON.MD'
 800       real(kind=8) :: energia(0:n_ene)
 801 !el local variables
 802       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 803       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 804       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran
 805
 806       etot=energia(0)
 807       evdw=energia(1)
 808       evdw2=energia(2)
 809 #ifdef SCP14
 810       evdw2=energia(2)+energia(18)
 811 #else
 812       evdw2=energia(2)
 813 #endif
 814       ees=energia(3)
 815 #ifdef SPLITELE
 816       evdw1=energia(16)
 817 #endif
 818       ecorr=energia(4)
 819       ecorr5=energia(5)
 820       ecorr6=energia(6)
 821       eel_loc=energia(7)
 822       eello_turn3=energia(8)
 823       eello_turn4=energia(9)
 824       eello_turn6=energia(10)
 825       ebe=energia(11)
 826       escloc=energia(12)
 827       etors=energia(13)
 828       etors_d=energia(14)
 829       ehpb=energia(15)
 830       edihcnstr=energia(19)
 831       estr=energia(17)
 832       Uconst=energia(20)
 833       esccor=energia(21)
 834       eliptran=energia(22)
 835
 836 #ifdef SPLITELE
 837       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
 838         estr,wbond,ebe,wang,&
 839         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 840         ecorr,wcorr,&
 841         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 842         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
 843         edihcnstr,ebr*nss,&
 844         Uconst,eliptran,wliptran,etot
 845    10 format (/'Virtual-chain energies:'// &
 846        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 847        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 848        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 849        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
 850        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 851        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 852        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 853        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 854        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 855        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 856        ' (SS bridges & dist. cnstr.)'/ &
 857        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 858        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 859        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 860        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 861        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 862        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 863        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 864        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 865        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 866        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 867        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
 868        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
 869        'ETOT=  ',1pE16.6,' (total)')
 870 #else
 871       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
 872         estr,wbond,ebe,wang,&
 873         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 874         ecorr,wcorr,&
 875         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 876         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
 877         ebr*nss,Uconst,eliptran,wliptran,etot
 878    10 format (/'Virtual-chain energies:'// &
 879        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 880        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 881        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 882        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 883        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 884        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 885        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 886        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 887        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 888        ' (SS bridges & dist. cnstr.)'/ &
 889        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 890        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 891        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 892        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 893        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 894        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 895        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 896        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 897        'EDIHC= ',1pE16.6,' (dihedral 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        'ETOT=  ',1pE16.6,' (total)')
 902 #endif
 903       return
 904       end subroutine enerprint
 905 !-----------------------------------------------------------------------------
 906       subroutine elj(evdw)
 907 !
 908 ! This subroutine calculates the interaction energy of nonbonded side chains
 909 ! assuming the LJ potential of interaction.
 910 !
 911 !      implicit real*8 (a-h,o-z)
 912 !      include 'DIMENSIONS'
 913       real(kind=8),parameter :: accur=1.0d-10
 914 !      include 'COMMON.GEO'
 915 !      include 'COMMON.VAR'
 916 !      include 'COMMON.LOCAL'
 917 !      include 'COMMON.CHAIN'
 918 !      include 'COMMON.DERIV'
 919 !      include 'COMMON.INTERACT'
 920 !      include 'COMMON.TORSION'
 921 !      include 'COMMON.SBRIDGE'
 922 !      include 'COMMON.NAMES'
 923 !      include 'COMMON.IOUNITS'
 924 !      include 'COMMON.CONTACTS'
 925       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
 926       integer :: num_conti
 927 !el local variables
 928       integer :: i,itypi,iint,j,itypi1,itypj,k
 929       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
 930       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
 931       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
 932
 933 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 934       evdw=0.0D0
 935 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
 936 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
 937 !      allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres)
 938 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))       !(3,maxconts,maxres)
 939
 940       do i=iatsc_s,iatsc_e
 941         itypi=iabs(itype(i))
 942         if (itypi.eq.ntyp1) cycle
 943         itypi1=iabs(itype(i+1))
 944         xi=c(1,nres+i)
 945         yi=c(2,nres+i)
 946         zi=c(3,nres+i)
 947 ! Change 12/1/95
 948         num_conti=0
 949 !
 950 ! Calculate SC interaction energy.
 951 !
 952         do iint=1,nint_gr(i)
 953 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 954 !d   &                  'iend=',iend(i,iint)
 955           do j=istart(i,iint),iend(i,iint)
 956             itypj=iabs(itype(j))
 957             if (itypj.eq.ntyp1) cycle
 958             xj=c(1,nres+j)-xi
 959             yj=c(2,nres+j)-yi
 960             zj=c(3,nres+j)-zi
 961 ! Change 12/1/95 to calculate four-body interactions
 962             rij=xj*xj+yj*yj+zj*zj
 963             rrij=1.0D0/rij
 964 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 965             eps0ij=eps(itypi,itypj)
 966             fac=rrij**expon2
 967             e1=fac*fac*aa_aq(itypi,itypj)
 968             e2=fac*bb_aq(itypi,itypj)
 969             evdwij=e1+e2
 970 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 971 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 972 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 973 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 974 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 975 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 976             evdw=evdw+evdwij
 977 !
 978 ! Calculate the components of the gradient in DC and X
 979 !
 980             fac=-rrij*(e1+evdwij)
 981             gg(1)=xj*fac
 982             gg(2)=yj*fac
 983             gg(3)=zj*fac
 984             do k=1,3
 985               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 986               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 987               gvdwc(k,i)=gvdwc(k,i)-gg(k)
 988               gvdwc(k,j)=gvdwc(k,j)+gg(k)
 989             enddo
 990 !grad            do k=i,j-1
 991 !grad              do l=1,3
 992 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
 993 !grad              enddo
 994 !grad            enddo
 995 !
 996 ! 12/1/95, revised on 5/20/97
 997 !
 998 ! Calculate the contact function. The ith column of the array JCONT will
 999 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1000 ! greater than I). The arrays FACONT and GACONT will contain the values of
1001 ! the contact function and its derivative.
1002 !
1003 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1004 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1005 ! Uncomment next line, if the correlation interactions are contact function only
1006             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1007               rij=dsqrt(rij)
1008               sigij=sigma(itypi,itypj)
1009               r0ij=rs0(itypi,itypj)
1010 !
1011 ! Check whether the SC's are not too far to make a contact.
1012 !
1013               rcut=1.5d0*r0ij
1014               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1015 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1016 !
1017               if (fcont.gt.0.0D0) then
1018 ! If the SC-SC distance if close to sigma, apply spline.
1019 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1020 !Adam &             fcont1,fprimcont1)
1021 !Adam           fcont1=1.0d0-fcont1
1022 !Adam           if (fcont1.gt.0.0d0) then
1023 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1024 !Adam             fcont=fcont*fcont1
1025 !Adam           endif
1026 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1027 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1028 !ga             do k=1,3
1029 !ga               gg(k)=gg(k)*eps0ij
1030 !ga             enddo
1031 !ga             eps0ij=-evdwij*eps0ij
1032 ! Uncomment for AL's type of SC correlation interactions.
1033 !adam           eps0ij=-evdwij
1034                 num_conti=num_conti+1
1035                 jcont(num_conti,i)=j
1036                 facont(num_conti,i)=fcont*eps0ij
1037                 fprimcont=eps0ij*fprimcont/rij
1038                 fcont=expon*fcont
1039 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1040 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1041 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1042 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1043                 gacont(1,num_conti,i)=-fprimcont*xj
1044                 gacont(2,num_conti,i)=-fprimcont*yj
1045                 gacont(3,num_conti,i)=-fprimcont*zj
1046 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1047 !d              write (iout,'(2i3,3f10.5)')
1048 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1049               endif
1050             endif
1051           enddo      ! j
1052         enddo        ! iint
1053 ! Change 12/1/95
1054         num_cont(i)=num_conti
1055       enddo          ! i
1056       do i=1,nct
1057         do j=1,3
1058           gvdwc(j,i)=expon*gvdwc(j,i)
1059           gvdwx(j,i)=expon*gvdwx(j,i)
1060         enddo
1061       enddo
1062 !******************************************************************************
1063 !
1064 !                              N O T E !!!
1065 !
1066 ! To save time, the factor of EXPON has been extracted from ALL components
1067 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1068 ! use!
1069 !
1070 !******************************************************************************
1071       return
1072       end subroutine elj
1073 !-----------------------------------------------------------------------------
1074       subroutine eljk(evdw)
1075 !
1076 ! This subroutine calculates the interaction energy of nonbonded side chains
1077 ! assuming the LJK potential of interaction.
1078 !
1079 !      implicit real*8 (a-h,o-z)
1080 !      include 'DIMENSIONS'
1081 !      include 'COMMON.GEO'
1082 !      include 'COMMON.VAR'
1083 !      include 'COMMON.LOCAL'
1084 !      include 'COMMON.CHAIN'
1085 !      include 'COMMON.DERIV'
1086 !      include 'COMMON.INTERACT'
1087 !      include 'COMMON.IOUNITS'
1088 !      include 'COMMON.NAMES'
1089       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1090       logical :: scheck
1091 !el local variables
1092       integer :: i,iint,j,itypi,itypi1,k,itypj
1093       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1094       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1095
1096 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1097       evdw=0.0D0
1098       do i=iatsc_s,iatsc_e
1099         itypi=iabs(itype(i))
1100         if (itypi.eq.ntyp1) cycle
1101         itypi1=iabs(itype(i+1))
1102         xi=c(1,nres+i)
1103         yi=c(2,nres+i)
1104         zi=c(3,nres+i)
1105 !
1106 ! Calculate SC interaction energy.
1107 !
1108         do iint=1,nint_gr(i)
1109           do j=istart(i,iint),iend(i,iint)
1110             itypj=iabs(itype(j))
1111             if (itypj.eq.ntyp1) cycle
1112             xj=c(1,nres+j)-xi
1113             yj=c(2,nres+j)-yi
1114             zj=c(3,nres+j)-zi
1115             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1116             fac_augm=rrij**expon
1117             e_augm=augm(itypi,itypj)*fac_augm
1118             r_inv_ij=dsqrt(rrij)
1119             rij=1.0D0/r_inv_ij
1120             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1121             fac=r_shift_inv**expon
1122             e1=fac*fac*aa_aq(itypi,itypj)
1123             e2=fac*bb_aq(itypi,itypj)
1124             evdwij=e_augm+e1+e2
1125 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1126 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1127 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1128 !d   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1129 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1130 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1131 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1132             evdw=evdw+evdwij
1133 !
1134 ! Calculate the components of the gradient in DC and X
1135 !
1136             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1137             gg(1)=xj*fac
1138             gg(2)=yj*fac
1139             gg(3)=zj*fac
1140             do k=1,3
1141               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1142               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1143               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1144               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1145             enddo
1146 !grad            do k=i,j-1
1147 !grad              do l=1,3
1148 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1149 !grad              enddo
1150 !grad            enddo
1151           enddo      ! j
1152         enddo        ! iint
1153       enddo          ! i
1154       do i=1,nct
1155         do j=1,3
1156           gvdwc(j,i)=expon*gvdwc(j,i)
1157           gvdwx(j,i)=expon*gvdwx(j,i)
1158         enddo
1159       enddo
1160       return
1161       end subroutine eljk
1162 !-----------------------------------------------------------------------------
1163       subroutine ebp(evdw)
1164 !
1165 ! This subroutine calculates the interaction energy of nonbonded side chains
1166 ! assuming the Berne-Pechukas potential of interaction.
1167 !
1168       use comm_srutu
1169       use calc_data
1170 !      implicit real*8 (a-h,o-z)
1171 !      include 'DIMENSIONS'
1172 !      include 'COMMON.GEO'
1173 !      include 'COMMON.VAR'
1174 !      include 'COMMON.LOCAL'
1175 !      include 'COMMON.CHAIN'
1176 !      include 'COMMON.DERIV'
1177 !      include 'COMMON.NAMES'
1178 !      include 'COMMON.INTERACT'
1179 !      include 'COMMON.IOUNITS'
1180 !      include 'COMMON.CALC'
1181       use comm_srutu
1182 !el      integer :: icall
1183 !el      common /srutu/ icall
1184 !     double precision rrsave(maxdim)
1185       logical :: lprn
1186 !el local variables
1187       integer :: iint,itypi,itypi1,itypj
1188       real(kind=8) :: rrij,xi,yi,zi
1189       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1190
1191 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1192       evdw=0.0D0
1193 !     if (icall.eq.0) then
1194 !       lprn=.true.
1195 !     else
1196         lprn=.false.
1197 !     endif
1198 !el      ind=0
1199       do i=iatsc_s,iatsc_e
1200         itypi=iabs(itype(i))
1201         if (itypi.eq.ntyp1) cycle
1202         itypi1=iabs(itype(i+1))
1203         xi=c(1,nres+i)
1204         yi=c(2,nres+i)
1205         zi=c(3,nres+i)
1206         dxi=dc_norm(1,nres+i)
1207         dyi=dc_norm(2,nres+i)
1208         dzi=dc_norm(3,nres+i)
1209 !        dsci_inv=dsc_inv(itypi)
1210         dsci_inv=vbld_inv(i+nres)
1211 !
1212 ! Calculate SC interaction energy.
1213 !
1214         do iint=1,nint_gr(i)
1215           do j=istart(i,iint),iend(i,iint)
1216 !el            ind=ind+1
1217             itypj=iabs(itype(j))
1218             if (itypj.eq.ntyp1) cycle
1219 !            dscj_inv=dsc_inv(itypj)
1220             dscj_inv=vbld_inv(j+nres)
1221             chi1=chi(itypi,itypj)
1222             chi2=chi(itypj,itypi)
1223             chi12=chi1*chi2
1224             chip1=chip(itypi)
1225             chip2=chip(itypj)
1226             chip12=chip1*chip2
1227             alf1=alp(itypi)
1228             alf2=alp(itypj)
1229             alf12=0.5D0*(alf1+alf2)
1230 ! For diagnostics only!!!
1231 !           chi1=0.0D0
1232 !           chi2=0.0D0
1233 !           chi12=0.0D0
1234 !           chip1=0.0D0
1235 !           chip2=0.0D0
1236 !           chip12=0.0D0
1237 !           alf1=0.0D0
1238 !           alf2=0.0D0
1239 !           alf12=0.0D0
1240             xj=c(1,nres+j)-xi
1241             yj=c(2,nres+j)-yi
1242             zj=c(3,nres+j)-zi
1243             dxj=dc_norm(1,nres+j)
1244             dyj=dc_norm(2,nres+j)
1245             dzj=dc_norm(3,nres+j)
1246             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1247 !d          if (icall.eq.0) then
1248 !d            rrsave(ind)=rrij
1249 !d          else
1250 !d            rrij=rrsave(ind)
1251 !d          endif
1252             rij=dsqrt(rrij)
1253 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1254             call sc_angular
1255 ! Calculate whole angle-dependent part of epsilon and contributions
1256 ! to its derivatives
1257             fac=(rrij*sigsq)**expon2
1258             e1=fac*fac*aa_aq(itypi,itypj)
1259             e2=fac*bb_aq(itypi,itypj)
1260             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1261             eps2der=evdwij*eps3rt
1262             eps3der=evdwij*eps2rt
1263             evdwij=evdwij*eps2rt*eps3rt
1264             evdw=evdw+evdwij
1265             if (lprn) then
1266             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1267             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1268 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1269 !d     &        restyp(itypi),i,restyp(itypj),j,
1270 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1271 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1272 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1273 !d     &        evdwij
1274             endif
1275 ! Calculate gradient components.
1276             e1=e1*eps1*eps2rt**2*eps3rt**2
1277             fac=-expon*(e1+evdwij)
1278             sigder=fac/sigsq
1279             fac=rrij*fac
1280 ! Calculate radial part of the gradient
1281             gg(1)=xj*fac
1282             gg(2)=yj*fac
1283             gg(3)=zj*fac
1284 ! Calculate the angular part of the gradient and sum add the contributions
1285 ! to the appropriate components of the Cartesian gradient.
1286             call sc_grad
1287           enddo      ! j
1288         enddo        ! iint
1289       enddo          ! i
1290 !     stop
1291       return
1292       end subroutine ebp
1293 !-----------------------------------------------------------------------------
1294       subroutine egb(evdw)
1295 !
1296 ! This subroutine calculates the interaction energy of nonbonded side chains
1297 ! assuming the Gay-Berne potential of interaction.
1298 !
1299       use calc_data
1300 !      implicit real*8 (a-h,o-z)
1301 !      include 'DIMENSIONS'
1302 !      include 'COMMON.GEO'
1303 !      include 'COMMON.VAR'
1304 !      include 'COMMON.LOCAL'
1305 !      include 'COMMON.CHAIN'
1306 !      include 'COMMON.DERIV'
1307 !      include 'COMMON.NAMES'
1308 !      include 'COMMON.INTERACT'
1309 !      include 'COMMON.IOUNITS'
1310 !      include 'COMMON.CALC'
1311 !      include 'COMMON.CONTROL'
1312 !      include 'COMMON.SBRIDGE'
1313       logical :: lprn
1314 !el local variables
1315       integer :: iint,itypi,itypi1,itypj,subchap
1316       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1317       real(kind=8) :: evdw,sig0ij
1318       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1319                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1320                     sslipi,sslipj,faclip
1321       integer :: ii
1322       real(kind=8) :: fracinbuf
1323
1324 !cccc      energy_dec=.false.
1325 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1326       evdw=0.0D0
1327       lprn=.false.
1328 !     if (icall.eq.0) lprn=.false.
1329 !el      ind=0
1330       do i=iatsc_s,iatsc_e
1331 !C        print *,"I am in EVDW",i
1332         itypi=iabs(itype(i))
1333 !        if (i.ne.47) cycle
1334         if (itypi.eq.ntyp1) cycle
1335         itypi1=iabs(itype(i+1))
1336         xi=c(1,nres+i)
1337         yi=c(2,nres+i)
1338         zi=c(3,nres+i)
1339           xi=dmod(xi,boxxsize)
1340           if (xi.lt.0) xi=xi+boxxsize
1341           yi=dmod(yi,boxysize)
1342           if (yi.lt.0) yi=yi+boxysize
1343           zi=dmod(zi,boxzsize)
1344           if (zi.lt.0) zi=zi+boxzsize
1345
1346        if ((zi.gt.bordlipbot)  &
1347         .and.(zi.lt.bordliptop)) then
1348 !C the energy transfer exist
1349         if (zi.lt.buflipbot) then
1350 !C what fraction I am in
1351          fracinbuf=1.0d0-  &
1352               ((zi-bordlipbot)/lipbufthick)
1353 !C lipbufthick is thickenes of lipid buffore
1354          sslipi=sscalelip(fracinbuf)
1355          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1356         elseif (zi.gt.bufliptop) then
1357          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1358          sslipi=sscalelip(fracinbuf)
1359          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1360         else
1361          sslipi=1.0d0
1362          ssgradlipi=0.0
1363         endif
1364        else
1365          sslipi=0.0d0
1366          ssgradlipi=0.0
1367        endif
1368        print *, sslipi,ssgradlipi
1369         dxi=dc_norm(1,nres+i)
1370         dyi=dc_norm(2,nres+i)
1371         dzi=dc_norm(3,nres+i)
1372 !        dsci_inv=dsc_inv(itypi)
1373         dsci_inv=vbld_inv(i+nres)
1374 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1375 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1376 !
1377 ! Calculate SC interaction energy.
1378 !
1379         do iint=1,nint_gr(i)
1380           do j=istart(i,iint),iend(i,iint)
1381             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1382               call dyn_ssbond_ene(i,j,evdwij)
1383               evdw=evdw+evdwij
1384               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1385                               'evdw',i,j,evdwij,' ss'
1386 !              if (energy_dec) write (iout,*) &
1387 !                              'evdw',i,j,evdwij,' ss'
1388             ELSE
1389 !el            ind=ind+1
1390             itypj=iabs(itype(j))
1391             if (itypj.eq.ntyp1) cycle
1392 !             if (j.ne.78) cycle
1393 !            dscj_inv=dsc_inv(itypj)
1394             dscj_inv=vbld_inv(j+nres)
1395 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1396 !              1.0d0/vbld(j+nres) !d
1397 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1398             sig0ij=sigma(itypi,itypj)
1399             chi1=chi(itypi,itypj)
1400             chi2=chi(itypj,itypi)
1401             chi12=chi1*chi2
1402             chip1=chip(itypi)
1403             chip2=chip(itypj)
1404             chip12=chip1*chip2
1405             alf1=alp(itypi)
1406             alf2=alp(itypj)
1407             alf12=0.5D0*(alf1+alf2)
1408 ! For diagnostics only!!!
1409 !           chi1=0.0D0
1410 !           chi2=0.0D0
1411 !           chi12=0.0D0
1412 !           chip1=0.0D0
1413 !           chip2=0.0D0
1414 !           chip12=0.0D0
1415 !           alf1=0.0D0
1416 !           alf2=0.0D0
1417 !           alf12=0.0D0
1418            xj=c(1,nres+j)
1419            yj=c(2,nres+j)
1420            zj=c(3,nres+j)
1421           xj=dmod(xj,boxxsize)
1422           if (xj.lt.0) xj=xj+boxxsize
1423           yj=dmod(yj,boxysize)
1424           if (yj.lt.0) yj=yj+boxysize
1425           zj=dmod(zj,boxzsize)
1426           if (zj.lt.0) zj=zj+boxzsize
1427 !          print *,"tu",xi,yi,zi,xj,yj,zj
1428 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1429 ! this fragment set correct epsilon for lipid phase
1430        if ((zj.gt.bordlipbot)  &
1431        .and.(zj.lt.bordliptop)) then
1432 !C the energy transfer exist
1433         if (zj.lt.buflipbot) then
1434 !C what fraction I am in
1435          fracinbuf=1.0d0-     &
1436              ((zj-bordlipbot)/lipbufthick)
1437 !C lipbufthick is thickenes of lipid buffore
1438          sslipj=sscalelip(fracinbuf)
1439          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1440         elseif (zj.gt.bufliptop) then
1441          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1442          sslipj=sscalelip(fracinbuf)
1443          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1444         else
1445          sslipj=1.0d0
1446          ssgradlipj=0.0
1447         endif
1448        else
1449          sslipj=0.0d0
1450          ssgradlipj=0.0
1451        endif
1452       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1453        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1454       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1455        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1456 !------------------------------------------------
1457       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1458       xj_safe=xj
1459       yj_safe=yj
1460       zj_safe=zj
1461       subchap=0
1462       do xshift=-1,1
1463       do yshift=-1,1
1464       do zshift=-1,1
1465           xj=xj_safe+xshift*boxxsize
1466           yj=yj_safe+yshift*boxysize
1467           zj=zj_safe+zshift*boxzsize
1468           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1469           if(dist_temp.lt.dist_init) then
1470             dist_init=dist_temp
1471             xj_temp=xj
1472             yj_temp=yj
1473             zj_temp=zj
1474             subchap=1
1475           endif
1476        enddo
1477        enddo
1478        enddo
1479        if (subchap.eq.1) then
1480           xj=xj_temp-xi
1481           yj=yj_temp-yi
1482           zj=zj_temp-zi
1483        else
1484           xj=xj_safe-xi
1485           yj=yj_safe-yi
1486           zj=zj_safe-zi
1487        endif
1488             dxj=dc_norm(1,nres+j)
1489             dyj=dc_norm(2,nres+j)
1490             dzj=dc_norm(3,nres+j)
1491 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1492 !            write (iout,*) "j",j," dc_norm",& !d
1493 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1494 !          write(iout,*)"rrij ",rrij
1495 !          write(iout,*)"xj yj zj ", xj, yj, zj
1496 !          write(iout,*)"xi yi zi ", xi, yi, zi
1497 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1498             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1499             rij=dsqrt(rrij)
1500             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1501             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1502 !            print *,sss_ele_cut,sss_ele_grad,&
1503 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1504             if (sss_ele_cut.le.0.0) cycle
1505 ! Calculate angle-dependent terms of energy and contributions to their
1506 ! derivatives.
1507             call sc_angular
1508             sigsq=1.0D0/sigsq
1509             sig=sig0ij*dsqrt(sigsq)
1510             rij_shift=1.0D0/rij-sig+sig0ij
1511 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1512 !            "sig0ij",sig0ij
1513 ! for diagnostics; uncomment
1514 !            rij_shift=1.2*sig0ij
1515 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1516             if (rij_shift.le.0.0D0) then
1517               evdw=1.0D20
1518 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1519 !d     &        restyp(itypi),i,restyp(itypj),j,
1520 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1521               return
1522             endif
1523             sigder=-sig*sigsq
1524 !---------------------------------------------------------------
1525             rij_shift=1.0D0/rij_shift
1526             fac=rij_shift**expon
1527             faclip=fac
1528             e1=fac*fac*aa!(itypi,itypj)
1529             e2=fac*bb!(itypi,itypj)
1530             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1531             eps2der=evdwij*eps3rt
1532             eps3der=evdwij*eps2rt
1533 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1534 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1535 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1536             evdwij=evdwij*eps2rt*eps3rt
1537             evdw=evdw+evdwij*sss_ele_cut
1538             if (lprn) then
1539             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1540             epsi=bb**2/aa!(itypi,itypj)
1541             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1542               restyp(itypi),i,restyp(itypj),j, &
1543               epsi,sigm,chi1,chi2,chip1,chip2, &
1544               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1545               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1546               evdwij
1547             endif
1548
1549             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1550                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1551 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1552 !            if (energy_dec) write (iout,*) &
1553 !                             'evdw',i,j,evdwij
1554
1555 ! Calculate gradient components.
1556             e1=e1*eps1*eps2rt**2*eps3rt**2
1557             fac=-expon*(e1+evdwij)*rij_shift
1558             sigder=fac*sigder
1559             fac=rij*fac
1560 !            print *,'before fac',fac,rij,evdwij
1561             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1562             /sigma(itypi,itypj)*rij
1563 !            print *,'grad part scale',fac,   &
1564 !             evdwij*sss_ele_grad/sss_ele_cut &
1565 !            /sigma(itypi,itypj)*rij
1566 !            fac=0.0d0
1567 ! Calculate the radial part of the gradient
1568             gg(1)=xj*fac
1569             gg(2)=yj*fac
1570             gg(3)=zj*fac
1571 !C Calculate the radial part of the gradient
1572             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1573        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1574         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1575        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1576             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1577             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1578
1579 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1580 ! Calculate angular part of the gradient.
1581             call sc_grad
1582             ENDIF    ! dyn_ss
1583           enddo      ! j
1584         enddo        ! iint
1585       enddo          ! i
1586 !      write (iout,*) "Number of loop steps in EGB:",ind
1587 !ccc      energy_dec=.false.
1588       return
1589       end subroutine egb
1590 !-----------------------------------------------------------------------------
1591       subroutine egbv(evdw)
1592 !
1593 ! This subroutine calculates the interaction energy of nonbonded side chains
1594 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1595 !
1596       use comm_srutu
1597       use calc_data
1598 !      implicit real*8 (a-h,o-z)
1599 !      include 'DIMENSIONS'
1600 !      include 'COMMON.GEO'
1601 !      include 'COMMON.VAR'
1602 !      include 'COMMON.LOCAL'
1603 !      include 'COMMON.CHAIN'
1604 !      include 'COMMON.DERIV'
1605 !      include 'COMMON.NAMES'
1606 !      include 'COMMON.INTERACT'
1607 !      include 'COMMON.IOUNITS'
1608 !      include 'COMMON.CALC'
1609       use comm_srutu
1610 !el      integer :: icall
1611 !el      common /srutu/ icall
1612       logical :: lprn
1613 !el local variables
1614       integer :: iint,itypi,itypi1,itypj
1615       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1616       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1617
1618 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1619       evdw=0.0D0
1620       lprn=.false.
1621 !     if (icall.eq.0) lprn=.true.
1622 !el      ind=0
1623       do i=iatsc_s,iatsc_e
1624         itypi=iabs(itype(i))
1625         if (itypi.eq.ntyp1) cycle
1626         itypi1=iabs(itype(i+1))
1627         xi=c(1,nres+i)
1628         yi=c(2,nres+i)
1629         zi=c(3,nres+i)
1630         dxi=dc_norm(1,nres+i)
1631         dyi=dc_norm(2,nres+i)
1632         dzi=dc_norm(3,nres+i)
1633 !        dsci_inv=dsc_inv(itypi)
1634         dsci_inv=vbld_inv(i+nres)
1635 !
1636 ! Calculate SC interaction energy.
1637 !
1638         do iint=1,nint_gr(i)
1639           do j=istart(i,iint),iend(i,iint)
1640 !el            ind=ind+1
1641             itypj=iabs(itype(j))
1642             if (itypj.eq.ntyp1) cycle
1643 !            dscj_inv=dsc_inv(itypj)
1644             dscj_inv=vbld_inv(j+nres)
1645             sig0ij=sigma(itypi,itypj)
1646             r0ij=r0(itypi,itypj)
1647             chi1=chi(itypi,itypj)
1648             chi2=chi(itypj,itypi)
1649             chi12=chi1*chi2
1650             chip1=chip(itypi)
1651             chip2=chip(itypj)
1652             chip12=chip1*chip2
1653             alf1=alp(itypi)
1654             alf2=alp(itypj)
1655             alf12=0.5D0*(alf1+alf2)
1656 ! For diagnostics only!!!
1657 !           chi1=0.0D0
1658 !           chi2=0.0D0
1659 !           chi12=0.0D0
1660 !           chip1=0.0D0
1661 !           chip2=0.0D0
1662 !           chip12=0.0D0
1663 !           alf1=0.0D0
1664 !           alf2=0.0D0
1665 !           alf12=0.0D0
1666             xj=c(1,nres+j)-xi
1667             yj=c(2,nres+j)-yi
1668             zj=c(3,nres+j)-zi
1669             dxj=dc_norm(1,nres+j)
1670             dyj=dc_norm(2,nres+j)
1671             dzj=dc_norm(3,nres+j)
1672             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1673             rij=dsqrt(rrij)
1674 ! Calculate angle-dependent terms of energy and contributions to their
1675 ! derivatives.
1676             call sc_angular
1677             sigsq=1.0D0/sigsq
1678             sig=sig0ij*dsqrt(sigsq)
1679             rij_shift=1.0D0/rij-sig+r0ij
1680 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1681             if (rij_shift.le.0.0D0) then
1682               evdw=1.0D20
1683               return
1684             endif
1685             sigder=-sig*sigsq
1686 !---------------------------------------------------------------
1687             rij_shift=1.0D0/rij_shift
1688             fac=rij_shift**expon
1689             e1=fac*fac*aa_aq(itypi,itypj)
1690             e2=fac*bb_aq(itypi,itypj)
1691             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1692             eps2der=evdwij*eps3rt
1693             eps3der=evdwij*eps2rt
1694             fac_augm=rrij**expon
1695             e_augm=augm(itypi,itypj)*fac_augm
1696             evdwij=evdwij*eps2rt*eps3rt
1697             evdw=evdw+evdwij+e_augm
1698             if (lprn) then
1699             sigm=dabs(aa_aq(itypi,itypj)/&
1700             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1701             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1702             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1703               restyp(itypi),i,restyp(itypj),j,&
1704               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1705               chi1,chi2,chip1,chip2,&
1706               eps1,eps2rt**2,eps3rt**2,&
1707               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1708               evdwij+e_augm
1709             endif
1710 ! Calculate gradient components.
1711             e1=e1*eps1*eps2rt**2*eps3rt**2
1712             fac=-expon*(e1+evdwij)*rij_shift
1713             sigder=fac*sigder
1714             fac=rij*fac-2*expon*rrij*e_augm
1715 ! Calculate the radial part of the gradient
1716             gg(1)=xj*fac
1717             gg(2)=yj*fac
1718             gg(3)=zj*fac
1719 ! Calculate angular part of the gradient.
1720             call sc_grad
1721           enddo      ! j
1722         enddo        ! iint
1723       enddo          ! i
1724       end subroutine egbv
1725 !-----------------------------------------------------------------------------
1726 !el      subroutine sc_angular in module geometry
1727 !-----------------------------------------------------------------------------
1728       subroutine e_softsphere(evdw)
1729 !
1730 ! This subroutine calculates the interaction energy of nonbonded side chains
1731 ! assuming the LJ potential of interaction.
1732 !
1733 !      implicit real*8 (a-h,o-z)
1734 !      include 'DIMENSIONS'
1735       real(kind=8),parameter :: accur=1.0d-10
1736 !      include 'COMMON.GEO'
1737 !      include 'COMMON.VAR'
1738 !      include 'COMMON.LOCAL'
1739 !      include 'COMMON.CHAIN'
1740 !      include 'COMMON.DERIV'
1741 !      include 'COMMON.INTERACT'
1742 !      include 'COMMON.TORSION'
1743 !      include 'COMMON.SBRIDGE'
1744 !      include 'COMMON.NAMES'
1745 !      include 'COMMON.IOUNITS'
1746 !      include 'COMMON.CONTACTS'
1747       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1748 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1749 !el local variables
1750       integer :: i,iint,j,itypi,itypi1,itypj,k
1751       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1752       real(kind=8) :: fac
1753
1754       evdw=0.0D0
1755       do i=iatsc_s,iatsc_e
1756         itypi=iabs(itype(i))
1757         if (itypi.eq.ntyp1) cycle
1758         itypi1=iabs(itype(i+1))
1759         xi=c(1,nres+i)
1760         yi=c(2,nres+i)
1761         zi=c(3,nres+i)
1762 !
1763 ! Calculate SC interaction energy.
1764 !
1765         do iint=1,nint_gr(i)
1766 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1767 !d   &                  'iend=',iend(i,iint)
1768           do j=istart(i,iint),iend(i,iint)
1769             itypj=iabs(itype(j))
1770             if (itypj.eq.ntyp1) cycle
1771             xj=c(1,nres+j)-xi
1772             yj=c(2,nres+j)-yi
1773             zj=c(3,nres+j)-zi
1774             rij=xj*xj+yj*yj+zj*zj
1775 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1776             r0ij=r0(itypi,itypj)
1777             r0ijsq=r0ij*r0ij
1778 !            print *,i,j,r0ij,dsqrt(rij)
1779             if (rij.lt.r0ijsq) then
1780               evdwij=0.25d0*(rij-r0ijsq)**2
1781               fac=rij-r0ijsq
1782             else
1783               evdwij=0.0d0
1784               fac=0.0d0
1785             endif
1786             evdw=evdw+evdwij
1787 !
1788 ! Calculate the components of the gradient in DC and X
1789 !
1790             gg(1)=xj*fac
1791             gg(2)=yj*fac
1792             gg(3)=zj*fac
1793             do k=1,3
1794               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1795               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1796               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1797               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1798             enddo
1799 !grad            do k=i,j-1
1800 !grad              do l=1,3
1801 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1802 !grad              enddo
1803 !grad            enddo
1804           enddo ! j
1805         enddo ! iint
1806       enddo ! i
1807       return
1808       end subroutine e_softsphere
1809 !-----------------------------------------------------------------------------
1810       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1811 !
1812 ! Soft-sphere potential of p-p interaction
1813 !
1814 !      implicit real*8 (a-h,o-z)
1815 !      include 'DIMENSIONS'
1816 !      include 'COMMON.CONTROL'
1817 !      include 'COMMON.IOUNITS'
1818 !      include 'COMMON.GEO'
1819 !      include 'COMMON.VAR'
1820 !      include 'COMMON.LOCAL'
1821 !      include 'COMMON.CHAIN'
1822 !      include 'COMMON.DERIV'
1823 !      include 'COMMON.INTERACT'
1824 !      include 'COMMON.CONTACTS'
1825 !      include 'COMMON.TORSION'
1826 !      include 'COMMON.VECTORS'
1827 !      include 'COMMON.FFIELD'
1828       real(kind=8),dimension(3) :: ggg
1829 !d      write(iout,*) 'In EELEC_soft_sphere'
1830 !el local variables
1831       integer :: i,j,k,num_conti,iteli,itelj
1832       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
1833       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
1834       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
1835
1836       ees=0.0D0
1837       evdw1=0.0D0
1838       eel_loc=0.0d0
1839       eello_turn3=0.0d0
1840       eello_turn4=0.0d0
1841 !el      ind=0
1842       do i=iatel_s,iatel_e
1843         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1844         dxi=dc(1,i)
1845         dyi=dc(2,i)
1846         dzi=dc(3,i)
1847         xmedi=c(1,i)+0.5d0*dxi
1848         ymedi=c(2,i)+0.5d0*dyi
1849         zmedi=c(3,i)+0.5d0*dzi
1850         num_conti=0
1851 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1852         do j=ielstart(i),ielend(i)
1853           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1854 !el          ind=ind+1
1855           iteli=itel(i)
1856           itelj=itel(j)
1857           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1858           r0ij=rpp(iteli,itelj)
1859           r0ijsq=r0ij*r0ij
1860           dxj=dc(1,j)
1861           dyj=dc(2,j)
1862           dzj=dc(3,j)
1863           xj=c(1,j)+0.5D0*dxj-xmedi
1864           yj=c(2,j)+0.5D0*dyj-ymedi
1865           zj=c(3,j)+0.5D0*dzj-zmedi
1866           rij=xj*xj+yj*yj+zj*zj
1867           if (rij.lt.r0ijsq) then
1868             evdw1ij=0.25d0*(rij-r0ijsq)**2
1869             fac=rij-r0ijsq
1870           else
1871             evdw1ij=0.0d0
1872             fac=0.0d0
1873           endif
1874           evdw1=evdw1+evdw1ij
1875 !
1876 ! Calculate contributions to the Cartesian gradient.
1877 !
1878           ggg(1)=fac*xj
1879           ggg(2)=fac*yj
1880           ggg(3)=fac*zj
1881           do k=1,3
1882             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1883             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1884           enddo
1885 !
1886 ! Loop over residues i+1 thru j-1.
1887 !
1888 !grad          do k=i+1,j-1
1889 !grad            do l=1,3
1890 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
1891 !grad            enddo
1892 !grad          enddo
1893         enddo ! j
1894       enddo   ! i
1895 !grad      do i=nnt,nct-1
1896 !grad        do k=1,3
1897 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1898 !grad        enddo
1899 !grad        do j=i+1,nct-1
1900 !grad          do k=1,3
1901 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1902 !grad          enddo
1903 !grad        enddo
1904 !grad      enddo
1905       return
1906       end subroutine eelec_soft_sphere
1907 !-----------------------------------------------------------------------------
1908       subroutine vec_and_deriv
1909 !      implicit real*8 (a-h,o-z)
1910 !      include 'DIMENSIONS'
1911 #ifdef MPI
1912       include 'mpif.h'
1913 #endif
1914 !      include 'COMMON.IOUNITS'
1915 !      include 'COMMON.GEO'
1916 !      include 'COMMON.VAR'
1917 !      include 'COMMON.LOCAL'
1918 !      include 'COMMON.CHAIN'
1919 !      include 'COMMON.VECTORS'
1920 !      include 'COMMON.SETUP'
1921 !      include 'COMMON.TIME1'
1922       real(kind=8),dimension(3,3,2) :: uyder,uzder
1923       real(kind=8),dimension(2) :: vbld_inv_temp
1924 ! Compute the local reference systems. For reference system (i), the
1925 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
1926 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1927 !el local variables
1928       integer :: i,j,k,l
1929       real(kind=8) :: facy,fac,costh
1930
1931 #ifdef PARVEC
1932       do i=ivec_start,ivec_end
1933 #else
1934       do i=1,nres-1
1935 #endif
1936           if (i.eq.nres-1) then
1937 ! Case of the last full residue
1938 ! Compute the Z-axis
1939             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1940             costh=dcos(pi-theta(nres))
1941             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1942             do k=1,3
1943               uz(k,i)=fac*uz(k,i)
1944             enddo
1945 ! Compute the derivatives of uz
1946             uzder(1,1,1)= 0.0d0
1947             uzder(2,1,1)=-dc_norm(3,i-1)
1948             uzder(3,1,1)= dc_norm(2,i-1)
1949             uzder(1,2,1)= dc_norm(3,i-1)
1950             uzder(2,2,1)= 0.0d0
1951             uzder(3,2,1)=-dc_norm(1,i-1)
1952             uzder(1,3,1)=-dc_norm(2,i-1)
1953             uzder(2,3,1)= dc_norm(1,i-1)
1954             uzder(3,3,1)= 0.0d0
1955             uzder(1,1,2)= 0.0d0
1956             uzder(2,1,2)= dc_norm(3,i)
1957             uzder(3,1,2)=-dc_norm(2,i)
1958             uzder(1,2,2)=-dc_norm(3,i)
1959             uzder(2,2,2)= 0.0d0
1960             uzder(3,2,2)= dc_norm(1,i)
1961             uzder(1,3,2)= dc_norm(2,i)
1962             uzder(2,3,2)=-dc_norm(1,i)
1963             uzder(3,3,2)= 0.0d0
1964 ! Compute the Y-axis
1965             facy=fac
1966             do k=1,3
1967               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1968             enddo
1969 ! Compute the derivatives of uy
1970             do j=1,3
1971               do k=1,3
1972                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
1973                               -dc_norm(k,i)*dc_norm(j,i-1)
1974                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1975               enddo
1976               uyder(j,j,1)=uyder(j,j,1)-costh
1977               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1978             enddo
1979             do j=1,2
1980               do k=1,3
1981                 do l=1,3
1982                   uygrad(l,k,j,i)=uyder(l,k,j)
1983                   uzgrad(l,k,j,i)=uzder(l,k,j)
1984                 enddo
1985               enddo
1986             enddo
1987             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1988             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1989             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1990             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1991           else
1992 ! Other residues
1993 ! Compute the Z-axis
1994             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1995             costh=dcos(pi-theta(i+2))
1996             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1997             do k=1,3
1998               uz(k,i)=fac*uz(k,i)
1999             enddo
2000 ! Compute the derivatives of uz
2001             uzder(1,1,1)= 0.0d0
2002             uzder(2,1,1)=-dc_norm(3,i+1)
2003             uzder(3,1,1)= dc_norm(2,i+1)
2004             uzder(1,2,1)= dc_norm(3,i+1)
2005             uzder(2,2,1)= 0.0d0
2006             uzder(3,2,1)=-dc_norm(1,i+1)
2007             uzder(1,3,1)=-dc_norm(2,i+1)
2008             uzder(2,3,1)= dc_norm(1,i+1)
2009             uzder(3,3,1)= 0.0d0
2010             uzder(1,1,2)= 0.0d0
2011             uzder(2,1,2)= dc_norm(3,i)
2012             uzder(3,1,2)=-dc_norm(2,i)
2013             uzder(1,2,2)=-dc_norm(3,i)
2014             uzder(2,2,2)= 0.0d0
2015             uzder(3,2,2)= dc_norm(1,i)
2016             uzder(1,3,2)= dc_norm(2,i)
2017             uzder(2,3,2)=-dc_norm(1,i)
2018             uzder(3,3,2)= 0.0d0
2019 ! Compute the Y-axis
2020             facy=fac
2021             do k=1,3
2022               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2023             enddo
2024 ! Compute the derivatives of uy
2025             do j=1,3
2026               do k=1,3
2027                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2028                               -dc_norm(k,i)*dc_norm(j,i+1)
2029                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2030               enddo
2031               uyder(j,j,1)=uyder(j,j,1)-costh
2032               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2033             enddo
2034             do j=1,2
2035               do k=1,3
2036                 do l=1,3
2037                   uygrad(l,k,j,i)=uyder(l,k,j)
2038                   uzgrad(l,k,j,i)=uzder(l,k,j)
2039                 enddo
2040               enddo
2041             enddo
2042             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2043             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2044             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2045             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2046           endif
2047       enddo
2048       do i=1,nres-1
2049         vbld_inv_temp(1)=vbld_inv(i+1)
2050         if (i.lt.nres-1) then
2051           vbld_inv_temp(2)=vbld_inv(i+2)
2052           else
2053           vbld_inv_temp(2)=vbld_inv(i)
2054           endif
2055         do j=1,2
2056           do k=1,3
2057             do l=1,3
2058               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2059               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2060             enddo
2061           enddo
2062         enddo
2063       enddo
2064 #if defined(PARVEC) && defined(MPI)
2065       if (nfgtasks1.gt.1) then
2066         time00=MPI_Wtime()
2067 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2068 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2069 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2070         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2071          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2072          FG_COMM1,IERR)
2073         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2074          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2075          FG_COMM1,IERR)
2076         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2077          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2078          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2079         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2080          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2081          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2082         time_gather=time_gather+MPI_Wtime()-time00
2083       endif
2084 !      if (fg_rank.eq.0) then
2085 !        write (iout,*) "Arrays UY and UZ"
2086 !        do i=1,nres-1
2087 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2088 !     &     (uz(k,i),k=1,3)
2089 !        enddo
2090 !      endif
2091 #endif
2092       return
2093       end subroutine vec_and_deriv
2094 !-----------------------------------------------------------------------------
2095       subroutine check_vecgrad
2096 !      implicit real*8 (a-h,o-z)
2097 !      include 'DIMENSIONS'
2098 !      include 'COMMON.IOUNITS'
2099 !      include 'COMMON.GEO'
2100 !      include 'COMMON.VAR'
2101 !      include 'COMMON.LOCAL'
2102 !      include 'COMMON.CHAIN'
2103 !      include 'COMMON.VECTORS'
2104       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt     !(3,3,2,maxres)
2105       real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
2106       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2107       real(kind=8),dimension(3) :: erij
2108       real(kind=8) :: delta=1.0d-7
2109 !el local variables
2110       integer :: i,j,k,l
2111
2112       call vec_and_deriv
2113 !d      do i=1,nres
2114 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2115 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2116 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2117 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2118 !d     &     (dc_norm(if90,i),if90=1,3)
2119 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2120 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2121 !d          write(iout,'(a)')
2122 !d      enddo
2123       do i=1,nres
2124         do j=1,2
2125           do k=1,3
2126             do l=1,3
2127               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2128               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2129             enddo
2130           enddo
2131         enddo
2132       enddo
2133       call vec_and_deriv
2134       do i=1,nres
2135         do j=1,3
2136           uyt(j,i)=uy(j,i)
2137           uzt(j,i)=uz(j,i)
2138         enddo
2139       enddo
2140       do i=1,nres
2141 !d        write (iout,*) 'i=',i
2142         do k=1,3
2143           erij(k)=dc_norm(k,i)
2144         enddo
2145         do j=1,3
2146           do k=1,3
2147             dc_norm(k,i)=erij(k)
2148           enddo
2149           dc_norm(j,i)=dc_norm(j,i)+delta
2150 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2151 !          do k=1,3
2152 !            dc_norm(k,i)=dc_norm(k,i)/fac
2153 !          enddo
2154 !          write (iout,*) (dc_norm(k,i),k=1,3)
2155 !          write (iout,*) (erij(k),k=1,3)
2156           call vec_and_deriv
2157           do k=1,3
2158             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2159             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2160             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2161             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2162           enddo
2163 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2164 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2165 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2166         enddo
2167         do k=1,3
2168           dc_norm(k,i)=erij(k)
2169         enddo
2170 !d        do k=1,3
2171 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2172 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2173 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2174 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2175 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2176 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2177 !d          write (iout,'(a)')
2178 !d        enddo
2179       enddo
2180       return
2181       end subroutine check_vecgrad
2182 !-----------------------------------------------------------------------------
2183       subroutine set_matrices
2184 !      implicit real*8 (a-h,o-z)
2185 !      include 'DIMENSIONS'
2186 #ifdef MPI
2187       include "mpif.h"
2188 !      include "COMMON.SETUP"
2189       integer :: IERR
2190       integer :: status(MPI_STATUS_SIZE)
2191 #endif
2192 !      include 'COMMON.IOUNITS'
2193 !      include 'COMMON.GEO'
2194 !      include 'COMMON.VAR'
2195 !      include 'COMMON.LOCAL'
2196 !      include 'COMMON.CHAIN'
2197 !      include 'COMMON.DERIV'
2198 !      include 'COMMON.INTERACT'
2199 !      include 'COMMON.CONTACTS'
2200 !      include 'COMMON.TORSION'
2201 !      include 'COMMON.VECTORS'
2202 !      include 'COMMON.FFIELD'
2203       real(kind=8) :: auxvec(2),auxmat(2,2)
2204       integer :: i,iti1,iti,k,l
2205       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2206 !       print *,"in set matrices"
2207 !
2208 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2209 ! to calculate the el-loc multibody terms of various order.
2210 !
2211 !AL el      mu=0.0d0
2212 #ifdef PARMAT
2213       do i=ivec_start+2,ivec_end+2
2214 #else
2215       do i=3,nres+1
2216 #endif
2217 !      print *,i,"i"
2218         if (i .lt. nres+1) then
2219           sin1=dsin(phi(i))
2220           cos1=dcos(phi(i))
2221           sintab(i-2)=sin1
2222           costab(i-2)=cos1
2223           obrot(1,i-2)=cos1
2224           obrot(2,i-2)=sin1
2225           sin2=dsin(2*phi(i))
2226           cos2=dcos(2*phi(i))
2227           sintab2(i-2)=sin2
2228           costab2(i-2)=cos2
2229           obrot2(1,i-2)=cos2
2230           obrot2(2,i-2)=sin2
2231           Ug(1,1,i-2)=-cos1
2232           Ug(1,2,i-2)=-sin1
2233           Ug(2,1,i-2)=-sin1
2234           Ug(2,2,i-2)= cos1
2235           Ug2(1,1,i-2)=-cos2
2236           Ug2(1,2,i-2)=-sin2
2237           Ug2(2,1,i-2)=-sin2
2238           Ug2(2,2,i-2)= cos2
2239         else
2240           costab(i-2)=1.0d0
2241           sintab(i-2)=0.0d0
2242           obrot(1,i-2)=1.0d0
2243           obrot(2,i-2)=0.0d0
2244           obrot2(1,i-2)=0.0d0
2245           obrot2(2,i-2)=0.0d0
2246           Ug(1,1,i-2)=1.0d0
2247           Ug(1,2,i-2)=0.0d0
2248           Ug(2,1,i-2)=0.0d0
2249           Ug(2,2,i-2)=1.0d0
2250           Ug2(1,1,i-2)=0.0d0
2251           Ug2(1,2,i-2)=0.0d0
2252           Ug2(2,1,i-2)=0.0d0
2253           Ug2(2,2,i-2)=0.0d0
2254         endif
2255         if (i .gt. 3 .and. i .lt. nres+1) then
2256           obrot_der(1,i-2)=-sin1
2257           obrot_der(2,i-2)= cos1
2258           Ugder(1,1,i-2)= sin1
2259           Ugder(1,2,i-2)=-cos1
2260           Ugder(2,1,i-2)=-cos1
2261           Ugder(2,2,i-2)=-sin1
2262           dwacos2=cos2+cos2
2263           dwasin2=sin2+sin2
2264           obrot2_der(1,i-2)=-dwasin2
2265           obrot2_der(2,i-2)= dwacos2
2266           Ug2der(1,1,i-2)= dwasin2
2267           Ug2der(1,2,i-2)=-dwacos2
2268           Ug2der(2,1,i-2)=-dwacos2
2269           Ug2der(2,2,i-2)=-dwasin2
2270         else
2271           obrot_der(1,i-2)=0.0d0
2272           obrot_der(2,i-2)=0.0d0
2273           Ugder(1,1,i-2)=0.0d0
2274           Ugder(1,2,i-2)=0.0d0
2275           Ugder(2,1,i-2)=0.0d0
2276           Ugder(2,2,i-2)=0.0d0
2277           obrot2_der(1,i-2)=0.0d0
2278           obrot2_der(2,i-2)=0.0d0
2279           Ug2der(1,1,i-2)=0.0d0
2280           Ug2der(1,2,i-2)=0.0d0
2281           Ug2der(2,1,i-2)=0.0d0
2282           Ug2der(2,2,i-2)=0.0d0
2283         endif
2284 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2285         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2286           iti = itortyp(itype(i-2))
2287         else
2288           iti=ntortyp+1
2289         endif
2290 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2291         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2292           iti1 = itortyp(itype(i-1))
2293         else
2294           iti1=ntortyp+1
2295         endif
2296 !          print *,iti,i,"iti",iti1,itype(i-1),itype(i-2)
2297 !d        write (iout,*) '*******i',i,' iti1',iti
2298 !d        write (iout,*) 'b1',b1(:,iti)
2299 !d        write (iout,*) 'b2',b2(:,iti)
2300 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2301 !        if (i .gt. iatel_s+2) then
2302         if (i .gt. nnt+2) then
2303           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2304           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2305           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2306           then
2307           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2308           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2309           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2310           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2311           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2312           endif
2313         else
2314           do k=1,2
2315             Ub2(k,i-2)=0.0d0
2316             Ctobr(k,i-2)=0.0d0
2317             Dtobr2(k,i-2)=0.0d0
2318             do l=1,2
2319               EUg(l,k,i-2)=0.0d0
2320               CUg(l,k,i-2)=0.0d0
2321               DUg(l,k,i-2)=0.0d0
2322               DtUg2(l,k,i-2)=0.0d0
2323             enddo
2324           enddo
2325         endif
2326         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2327         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2328         do k=1,2
2329           muder(k,i-2)=Ub2der(k,i-2)
2330         enddo
2331 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2332         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2333           if (itype(i-1).le.ntyp) then
2334             iti1 = itortyp(itype(i-1))
2335           else
2336             iti1=ntortyp+1
2337           endif
2338         else
2339           iti1=ntortyp+1
2340         endif
2341         do k=1,2
2342           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2343         enddo
2344 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2345 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2346 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2347 !d        write (iout,*) 'mu1',mu1(:,i-2)
2348 !d        write (iout,*) 'mu2',mu2(:,i-2)
2349         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2350         then
2351         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2352         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2353         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2354         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2355         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2356 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2357         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2358         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2359         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2360         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2361         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2362         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2363         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2364         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2365         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2366         endif
2367       enddo
2368 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2369 ! The order of matrices is from left to right.
2370       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2371       then
2372 !      do i=max0(ivec_start,2),ivec_end
2373       do i=2,nres-1
2374         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2375         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2376         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2377         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2378         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2379         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2380         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2381         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2382       enddo
2383       endif
2384 #if defined(MPI) && defined(PARMAT)
2385 #ifdef DEBUG
2386 !      if (fg_rank.eq.0) then
2387         write (iout,*) "Arrays UG and UGDER before GATHER"
2388         do i=1,nres-1
2389           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2390            ((ug(l,k,i),l=1,2),k=1,2),&
2391            ((ugder(l,k,i),l=1,2),k=1,2)
2392         enddo
2393         write (iout,*) "Arrays UG2 and UG2DER"
2394         do i=1,nres-1
2395           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2396            ((ug2(l,k,i),l=1,2),k=1,2),&
2397            ((ug2der(l,k,i),l=1,2),k=1,2)
2398         enddo
2399         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2400         do i=1,nres-1
2401           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2402            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2403            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2404         enddo
2405         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2406         do i=1,nres-1
2407           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2408            costab(i),sintab(i),costab2(i),sintab2(i)
2409         enddo
2410         write (iout,*) "Array MUDER"
2411         do i=1,nres-1
2412           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2413         enddo
2414 !      endif
2415 #endif
2416       if (nfgtasks.gt.1) then
2417         time00=MPI_Wtime()
2418 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2419 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2420 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2421 #ifdef MATGATHER
2422         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2423          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2424          FG_COMM1,IERR)
2425         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2426          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2427          FG_COMM1,IERR)
2428         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2429          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2430          FG_COMM1,IERR)
2431         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2432          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2433          FG_COMM1,IERR)
2434         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2435          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2436          FG_COMM1,IERR)
2437         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2438          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2439          FG_COMM1,IERR)
2440         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2441          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2442          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2443         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2444          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2445          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2446         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2447          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2448          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2449         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2450          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2451          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2452         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2453         then
2454         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2455          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2456          FG_COMM1,IERR)
2457         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2458          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2459          FG_COMM1,IERR)
2460         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2461          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2462          FG_COMM1,IERR)
2463        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2464          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2465          FG_COMM1,IERR)
2466         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2467          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2468          FG_COMM1,IERR)
2469         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2470          ivec_count(fg_rank1),&
2471          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2472          FG_COMM1,IERR)
2473         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2474          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2475          FG_COMM1,IERR)
2476         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2477          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2478          FG_COMM1,IERR)
2479         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2480          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2481          FG_COMM1,IERR)
2482         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2483          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2484          FG_COMM1,IERR)
2485         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2486          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2487          FG_COMM1,IERR)
2488         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2489          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2490          FG_COMM1,IERR)
2491         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2492          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2493          FG_COMM1,IERR)
2494         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2495          ivec_count(fg_rank1),&
2496          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2497          FG_COMM1,IERR)
2498         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2499          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2500          FG_COMM1,IERR)
2501        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2502          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2503          FG_COMM1,IERR)
2504         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2505          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2506          FG_COMM1,IERR)
2507        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2508          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2509          FG_COMM1,IERR)
2510         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2511          ivec_count(fg_rank1),&
2512          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2513          FG_COMM1,IERR)
2514         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2515          ivec_count(fg_rank1),&
2516          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2517          FG_COMM1,IERR)
2518         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2519          ivec_count(fg_rank1),&
2520          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2521          MPI_MAT2,FG_COMM1,IERR)
2522         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2523          ivec_count(fg_rank1),&
2524          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2525          MPI_MAT2,FG_COMM1,IERR)
2526         endif
2527 #else
2528 ! Passes matrix info through the ring
2529       isend=fg_rank1
2530       irecv=fg_rank1-1
2531       if (irecv.lt.0) irecv=nfgtasks1-1
2532       iprev=irecv
2533       inext=fg_rank1+1
2534       if (inext.ge.nfgtasks1) inext=0
2535       do i=1,nfgtasks1-1
2536 !        write (iout,*) "isend",isend," irecv",irecv
2537 !        call flush(iout)
2538         lensend=lentyp(isend)
2539         lenrecv=lentyp(irecv)
2540 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2541 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2542 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2543 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2544 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2545 !        write (iout,*) "Gather ROTAT1"
2546 !        call flush(iout)
2547 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2548 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2549 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2550 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2551 !        write (iout,*) "Gather ROTAT2"
2552 !        call flush(iout)
2553         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2554          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2555          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2556          iprev,4400+irecv,FG_COMM,status,IERR)
2557 !        write (iout,*) "Gather ROTAT_OLD"
2558 !        call flush(iout)
2559         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2560          MPI_PRECOMP11(lensend),inext,5500+isend,&
2561          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2562          iprev,5500+irecv,FG_COMM,status,IERR)
2563 !        write (iout,*) "Gather PRECOMP11"
2564 !        call flush(iout)
2565         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2566          MPI_PRECOMP12(lensend),inext,6600+isend,&
2567          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2568          iprev,6600+irecv,FG_COMM,status,IERR)
2569 !        write (iout,*) "Gather PRECOMP12"
2570 !        call flush(iout)
2571         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2572         then
2573         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2574          MPI_ROTAT2(lensend),inext,7700+isend,&
2575          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2576          iprev,7700+irecv,FG_COMM,status,IERR)
2577 !        write (iout,*) "Gather PRECOMP21"
2578 !        call flush(iout)
2579         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2580          MPI_PRECOMP22(lensend),inext,8800+isend,&
2581          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2582          iprev,8800+irecv,FG_COMM,status,IERR)
2583 !        write (iout,*) "Gather PRECOMP22"
2584 !        call flush(iout)
2585         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2586          MPI_PRECOMP23(lensend),inext,9900+isend,&
2587          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2588          MPI_PRECOMP23(lenrecv),&
2589          iprev,9900+irecv,FG_COMM,status,IERR)
2590 !        write (iout,*) "Gather PRECOMP23"
2591 !        call flush(iout)
2592         endif
2593         isend=irecv
2594         irecv=irecv-1
2595         if (irecv.lt.0) irecv=nfgtasks1-1
2596       enddo
2597 #endif
2598         time_gather=time_gather+MPI_Wtime()-time00
2599       endif
2600 #ifdef DEBUG
2601 !      if (fg_rank.eq.0) then
2602         write (iout,*) "Arrays UG and UGDER"
2603         do i=1,nres-1
2604           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2605            ((ug(l,k,i),l=1,2),k=1,2),&
2606            ((ugder(l,k,i),l=1,2),k=1,2)
2607         enddo
2608         write (iout,*) "Arrays UG2 and UG2DER"
2609         do i=1,nres-1
2610           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2611            ((ug2(l,k,i),l=1,2),k=1,2),&
2612            ((ug2der(l,k,i),l=1,2),k=1,2)
2613         enddo
2614         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2615         do i=1,nres-1
2616           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2617            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2618            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2619         enddo
2620         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2621         do i=1,nres-1
2622           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2623            costab(i),sintab(i),costab2(i),sintab2(i)
2624         enddo
2625         write (iout,*) "Array MUDER"
2626         do i=1,nres-1
2627           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2628         enddo
2629 !      endif
2630 #endif
2631 #endif
2632 !d      do i=1,nres
2633 !d        iti = itortyp(itype(i))
2634 !d        write (iout,*) i
2635 !d        do j=1,2
2636 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2637 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2638 !d        enddo
2639 !d      enddo
2640       return
2641       end subroutine set_matrices
2642 !-----------------------------------------------------------------------------
2643       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2644 !
2645 ! This subroutine calculates the average interaction energy and its gradient
2646 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2647 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2648 ! The potential depends both on the distance of peptide-group centers and on
2649 ! the orientation of the CA-CA virtual bonds.
2650 !
2651       use comm_locel
2652 !      implicit real*8 (a-h,o-z)
2653 #ifdef MPI
2654       include 'mpif.h'
2655 #endif
2656 !      include 'DIMENSIONS'
2657 !      include 'COMMON.CONTROL'
2658 !      include 'COMMON.SETUP'
2659 !      include 'COMMON.IOUNITS'
2660 !      include 'COMMON.GEO'
2661 !      include 'COMMON.VAR'
2662 !      include 'COMMON.LOCAL'
2663 !      include 'COMMON.CHAIN'
2664 !      include 'COMMON.DERIV'
2665 !      include 'COMMON.INTERACT'
2666 !      include 'COMMON.CONTACTS'
2667 !      include 'COMMON.TORSION'
2668 !      include 'COMMON.VECTORS'
2669 !      include 'COMMON.FFIELD'
2670 !      include 'COMMON.TIME1'
2671       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2672       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2673       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2674 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2675       real(kind=8),dimension(4) :: muij
2676 !el      integer :: num_conti,j1,j2
2677 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2678 !el        dz_normi,xmedi,ymedi,zmedi
2679
2680 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2681 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2682 !el          num_conti,j1,j2
2683
2684 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2685 #ifdef MOMENT
2686       real(kind=8) :: scal_el=1.0d0
2687 #else
2688       real(kind=8) :: scal_el=0.5d0
2689 #endif
2690 ! 12/13/98
2691 ! 13-go grudnia roku pamietnego...
2692       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2693                                              0.0d0,1.0d0,0.0d0,&
2694                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2695 !el local variables
2696       integer :: i,k,j
2697       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2698       real(kind=8) :: fac,t_eelecij,fracinbuf
2699
2700
2701 !d      write(iout,*) 'In EELEC'
2702 !        print *,"IN EELEC"
2703 !d      do i=1,nloctyp
2704 !d        write(iout,*) 'Type',i
2705 !d        write(iout,*) 'B1',B1(:,i)
2706 !d        write(iout,*) 'B2',B2(:,i)
2707 !d        write(iout,*) 'CC',CC(:,:,i)
2708 !d        write(iout,*) 'DD',DD(:,:,i)
2709 !d        write(iout,*) 'EE',EE(:,:,i)
2710 !d      enddo
2711 !d      call check_vecgrad
2712 !d      stop
2713 !      ees=0.0d0  !AS
2714 !      evdw1=0.0d0
2715 !      eel_loc=0.0d0
2716 !      eello_turn3=0.0d0
2717 !      eello_turn4=0.0d0
2718       t_eelecij=0.0d0
2719       ees=0.0D0
2720       evdw1=0.0D0
2721       eel_loc=0.0d0
2722       eello_turn3=0.0d0
2723       eello_turn4=0.0d0
2724 !
2725
2726       if (icheckgrad.eq.1) then
2727 !el
2728 !        do i=0,2*nres+2
2729 !          dc_norm(1,i)=0.0d0
2730 !          dc_norm(2,i)=0.0d0
2731 !          dc_norm(3,i)=0.0d0
2732 !        enddo
2733         do i=1,nres-1
2734           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2735           do k=1,3
2736             dc_norm(k,i)=dc(k,i)*fac
2737           enddo
2738 !          write (iout,*) 'i',i,' fac',fac
2739         enddo
2740       endif
2741       print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
2742         wturn6
2743       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2744           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2745           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2746 !        call vec_and_deriv
2747 #ifdef TIMING
2748         time01=MPI_Wtime()
2749 #endif
2750 !        print *, "before set matrices"
2751         call set_matrices
2752 !        print *, "after set matrices"
2753
2754 #ifdef TIMING
2755         time_mat=time_mat+MPI_Wtime()-time01
2756 #endif
2757       endif
2758 !       print *, "after set matrices"
2759 !d      do i=1,nres-1
2760 !d        write (iout,*) 'i=',i
2761 !d        do k=1,3
2762 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2763 !d        enddo
2764 !d        do k=1,3
2765 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2766 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2767 !d        enddo
2768 !d      enddo
2769       t_eelecij=0.0d0
2770       ees=0.0D0
2771       evdw1=0.0D0
2772       eel_loc=0.0d0
2773       eello_turn3=0.0d0
2774       eello_turn4=0.0d0
2775 !el      ind=0
2776       do i=1,nres
2777         num_cont_hb(i)=0
2778       enddo
2779 !d      print '(a)','Enter EELEC'
2780 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2781 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2782 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2783       do i=1,nres
2784         gel_loc_loc(i)=0.0d0
2785         gcorr_loc(i)=0.0d0
2786       enddo
2787 !
2788 !
2789 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2790 !
2791 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
2792 !
2793
2794
2795 !        print *,"before iturn3 loop"
2796       do i=iturn3_start,iturn3_end
2797         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2798         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2799         dxi=dc(1,i)
2800         dyi=dc(2,i)
2801         dzi=dc(3,i)
2802         dx_normi=dc_norm(1,i)
2803         dy_normi=dc_norm(2,i)
2804         dz_normi=dc_norm(3,i)
2805         xmedi=c(1,i)+0.5d0*dxi
2806         ymedi=c(2,i)+0.5d0*dyi
2807         zmedi=c(3,i)+0.5d0*dzi
2808           xmedi=dmod(xmedi,boxxsize)
2809           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2810           ymedi=dmod(ymedi,boxysize)
2811           if (ymedi.lt.0) ymedi=ymedi+boxysize
2812           zmedi=dmod(zmedi,boxzsize)
2813           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2814         num_conti=0
2815        if ((zmedi.gt.bordlipbot) &
2816         .and.(zmedi.lt.bordliptop)) then
2817 !C the energy transfer exist
2818         if (zmedi.lt.buflipbot) then
2819 !C what fraction I am in
2820          fracinbuf=1.0d0- &
2821                ((zmedi-bordlipbot)/lipbufthick)
2822 !C lipbufthick is thickenes of lipid buffore
2823          sslipi=sscalelip(fracinbuf)
2824          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2825         elseif (zmedi.gt.bufliptop) then
2826          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2827          sslipi=sscalelip(fracinbuf)
2828          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2829         else
2830          sslipi=1.0d0
2831          ssgradlipi=0.0
2832         endif
2833        else
2834          sslipi=0.0d0
2835          ssgradlipi=0.0
2836        endif
2837 !       print *,i,sslipi,ssgradlipi
2838        call eelecij(i,i+2,ees,evdw1,eel_loc)
2839         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2840         num_cont_hb(i)=num_conti
2841       enddo
2842       do i=iturn4_start,iturn4_end
2843         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2844           .or. itype(i+3).eq.ntyp1 &
2845           .or. itype(i+4).eq.ntyp1) cycle
2846         dxi=dc(1,i)
2847         dyi=dc(2,i)
2848         dzi=dc(3,i)
2849         dx_normi=dc_norm(1,i)
2850         dy_normi=dc_norm(2,i)
2851         dz_normi=dc_norm(3,i)
2852         xmedi=c(1,i)+0.5d0*dxi
2853         ymedi=c(2,i)+0.5d0*dyi
2854         zmedi=c(3,i)+0.5d0*dzi
2855           xmedi=dmod(xmedi,boxxsize)
2856           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2857           ymedi=dmod(ymedi,boxysize)
2858           if (ymedi.lt.0) ymedi=ymedi+boxysize
2859           zmedi=dmod(zmedi,boxzsize)
2860           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2861        if ((zmedi.gt.bordlipbot)  &
2862        .and.(zmedi.lt.bordliptop)) then
2863 !C the energy transfer exist
2864         if (zmedi.lt.buflipbot) then
2865 !C what fraction I am in
2866          fracinbuf=1.0d0- &
2867              ((zmedi-bordlipbot)/lipbufthick)
2868 !C lipbufthick is thickenes of lipid buffore
2869          sslipi=sscalelip(fracinbuf)
2870          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2871         elseif (zmedi.gt.bufliptop) then
2872          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2873          sslipi=sscalelip(fracinbuf)
2874          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2875         else
2876          sslipi=1.0d0
2877          ssgradlipi=0.0
2878         endif
2879        else
2880          sslipi=0.0d0
2881          ssgradlipi=0.0
2882        endif
2883
2884         num_conti=num_cont_hb(i)
2885         call eelecij(i,i+3,ees,evdw1,eel_loc)
2886         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
2887          call eturn4(i,eello_turn4)
2888         num_cont_hb(i)=num_conti
2889       enddo   ! i
2890 !
2891 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2892 !
2893       do i=iatel_s,iatel_e
2894         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2895         dxi=dc(1,i)
2896         dyi=dc(2,i)
2897         dzi=dc(3,i)
2898         dx_normi=dc_norm(1,i)
2899         dy_normi=dc_norm(2,i)
2900         dz_normi=dc_norm(3,i)
2901         xmedi=c(1,i)+0.5d0*dxi
2902         ymedi=c(2,i)+0.5d0*dyi
2903         zmedi=c(3,i)+0.5d0*dzi
2904           xmedi=dmod(xmedi,boxxsize)
2905           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2906           ymedi=dmod(ymedi,boxysize)
2907           if (ymedi.lt.0) ymedi=ymedi+boxysize
2908           zmedi=dmod(zmedi,boxzsize)
2909           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2910        if ((zmedi.gt.bordlipbot)  &
2911         .and.(zmedi.lt.bordliptop)) then
2912 !C the energy transfer exist
2913         if (zmedi.lt.buflipbot) then
2914 !C what fraction I am in
2915          fracinbuf=1.0d0- &
2916              ((zmedi-bordlipbot)/lipbufthick)
2917 !C lipbufthick is thickenes of lipid buffore
2918          sslipi=sscalelip(fracinbuf)
2919          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2920         elseif (zmedi.gt.bufliptop) then
2921          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2922          sslipi=sscalelip(fracinbuf)
2923          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2924         else
2925          sslipi=1.0d0
2926          ssgradlipi=0.0
2927         endif
2928        else
2929          sslipi=0.0d0
2930          ssgradlipi=0.0
2931        endif
2932
2933 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2934         num_conti=num_cont_hb(i)
2935         do j=ielstart(i),ielend(i)
2936 !          write (iout,*) i,j,itype(i),itype(j)
2937           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2938           call eelecij(i,j,ees,evdw1,eel_loc)
2939         enddo ! j
2940         num_cont_hb(i)=num_conti
2941       enddo   ! i
2942 !      write (iout,*) "Number of loop steps in EELEC:",ind
2943 !d      do i=1,nres
2944 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
2945 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2946 !d      enddo
2947 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2948 !cc      eel_loc=eel_loc+eello_turn3
2949 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2950       return
2951       end subroutine eelec
2952 !-----------------------------------------------------------------------------
2953       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2954
2955       use comm_locel
2956 !      implicit real*8 (a-h,o-z)
2957 !      include 'DIMENSIONS'
2958 #ifdef MPI
2959       include "mpif.h"
2960 #endif
2961 !      include 'COMMON.CONTROL'
2962 !      include 'COMMON.IOUNITS'
2963 !      include 'COMMON.GEO'
2964 !      include 'COMMON.VAR'
2965 !      include 'COMMON.LOCAL'
2966 !      include 'COMMON.CHAIN'
2967 !      include 'COMMON.DERIV'
2968 !      include 'COMMON.INTERACT'
2969 !      include 'COMMON.CONTACTS'
2970 !      include 'COMMON.TORSION'
2971 !      include 'COMMON.VECTORS'
2972 !      include 'COMMON.FFIELD'
2973 !      include 'COMMON.TIME1'
2974       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
2975       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2976       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2977 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2978       real(kind=8),dimension(4) :: muij
2979       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
2980                     dist_temp, dist_init,rlocshield,fracinbuf
2981       integer xshift,yshift,zshift,ilist,iresshield
2982 !el      integer :: num_conti,j1,j2
2983 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2984 !el        dz_normi,xmedi,ymedi,zmedi
2985
2986 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2987 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2988 !el          num_conti,j1,j2
2989
2990 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2991 #ifdef MOMENT
2992       real(kind=8) :: scal_el=1.0d0
2993 #else
2994       real(kind=8) :: scal_el=0.5d0
2995 #endif
2996 ! 12/13/98
2997 ! 13-go grudnia roku pamietnego...
2998       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2999                                              0.0d0,1.0d0,0.0d0,&
3000                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3001 !      integer :: maxconts=nres/4
3002 !el local variables
3003       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3004       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3005       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3006       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3007                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3008                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3009                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3010                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3011                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3012                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3013                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3014 !      maxconts=nres/4
3015 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3016 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3017
3018 !          time00=MPI_Wtime()
3019 !d      write (iout,*) "eelecij",i,j
3020 !          ind=ind+1
3021           iteli=itel(i)
3022           itelj=itel(j)
3023           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3024           aaa=app(iteli,itelj)
3025           bbb=bpp(iteli,itelj)
3026           ael6i=ael6(iteli,itelj)
3027           ael3i=ael3(iteli,itelj)
3028           dxj=dc(1,j)
3029           dyj=dc(2,j)
3030           dzj=dc(3,j)
3031           dx_normj=dc_norm(1,j)
3032           dy_normj=dc_norm(2,j)
3033           dz_normj=dc_norm(3,j)
3034 !          xj=c(1,j)+0.5D0*dxj-xmedi
3035 !          yj=c(2,j)+0.5D0*dyj-ymedi
3036 !          zj=c(3,j)+0.5D0*dzj-zmedi
3037           xj=c(1,j)+0.5D0*dxj
3038           yj=c(2,j)+0.5D0*dyj
3039           zj=c(3,j)+0.5D0*dzj
3040           xj=mod(xj,boxxsize)
3041           if (xj.lt.0) xj=xj+boxxsize
3042           yj=mod(yj,boxysize)
3043           if (yj.lt.0) yj=yj+boxysize
3044           zj=mod(zj,boxzsize)
3045           if (zj.lt.0) zj=zj+boxzsize
3046        if ((zj.gt.bordlipbot)  &
3047        .and.(zj.lt.bordliptop)) then
3048 !C the energy transfer exist
3049         if (zj.lt.buflipbot) then
3050 !C what fraction I am in
3051          fracinbuf=1.0d0-     &
3052              ((zj-bordlipbot)/lipbufthick)
3053 !C lipbufthick is thickenes of lipid buffore
3054          sslipj=sscalelip(fracinbuf)
3055          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3056         elseif (zj.gt.bufliptop) then
3057          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3058          sslipj=sscalelip(fracinbuf)
3059          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3060         else
3061          sslipj=1.0d0
3062          ssgradlipj=0.0
3063         endif
3064        else
3065          sslipj=0.0d0
3066          ssgradlipj=0.0
3067        endif
3068
3069       isubchap=0
3070       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3071       xj_safe=xj
3072       yj_safe=yj
3073       zj_safe=zj
3074       do xshift=-1,1
3075       do yshift=-1,1
3076       do zshift=-1,1
3077           xj=xj_safe+xshift*boxxsize
3078           yj=yj_safe+yshift*boxysize
3079           zj=zj_safe+zshift*boxzsize
3080           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3081           if(dist_temp.lt.dist_init) then
3082             dist_init=dist_temp
3083             xj_temp=xj
3084             yj_temp=yj
3085             zj_temp=zj
3086             isubchap=1
3087           endif
3088        enddo
3089        enddo
3090        enddo
3091        if (isubchap.eq.1) then
3092 !C          print *,i,j
3093           xj=xj_temp-xmedi
3094           yj=yj_temp-ymedi
3095           zj=zj_temp-zmedi
3096        else
3097           xj=xj_safe-xmedi
3098           yj=yj_safe-ymedi
3099           zj=zj_safe-zmedi
3100        endif
3101
3102           rij=xj*xj+yj*yj+zj*zj
3103           rrmij=1.0D0/rij
3104           rij=dsqrt(rij)
3105 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3106             sss_ele_cut=sscale_ele(rij)
3107             sss_ele_grad=sscagrad_ele(rij)
3108 !             sss_ele_cut=1.0d0
3109 !             sss_ele_grad=0.0d0
3110 !            print *,sss_ele_cut,sss_ele_grad,&
3111 !            (rij),r_cut_ele,rlamb_ele
3112 !            if (sss_ele_cut.le.0.0) go to 128
3113
3114           rmij=1.0D0/rij
3115           r3ij=rrmij*rmij
3116           r6ij=r3ij*r3ij
3117           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3118           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3119           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3120           fac=cosa-3.0D0*cosb*cosg
3121           ev1=aaa*r6ij*r6ij
3122 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3123           if (j.eq.i+2) ev1=scal_el*ev1
3124           ev2=bbb*r6ij
3125           fac3=ael6i*r6ij
3126           fac4=ael3i*r3ij
3127           evdwij=ev1+ev2
3128           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3129           el2=fac4*fac
3130 !          eesij=el1+el2
3131           if (shield_mode.gt.0) then
3132 !C          fac_shield(i)=0.4
3133 !C          fac_shield(j)=0.6
3134           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3135           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3136           eesij=(el1+el2)
3137           ees=ees+eesij*sss_ele_cut
3138 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3139 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3140           else
3141           fac_shield(i)=1.0
3142           fac_shield(j)=1.0
3143           eesij=(el1+el2)
3144           ees=ees+eesij   &
3145             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3146 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3147           endif
3148
3149 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3150           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3151 !          ees=ees+eesij*sss_ele_cut
3152           evdw1=evdw1+evdwij*sss_ele_cut  &
3153            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3154 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3155 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3156 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3157 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3158
3159           if (energy_dec) then
3160 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3161 !                  'evdw1',i,j,evdwij,&
3162 !                  iteli,itelj,aaa,evdw1
3163               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3164               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3165           endif
3166 !
3167 ! Calculate contributions to the Cartesian gradient.
3168 !
3169 #ifdef SPLITELE
3170           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3171               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3172           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3173              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3174           fac1=fac
3175           erij(1)=xj*rmij
3176           erij(2)=yj*rmij
3177           erij(3)=zj*rmij
3178 !
3179 ! Radial derivatives. First process both termini of the fragment (i,j)
3180 !
3181           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3182           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3183           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3184            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3185           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3186             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3187
3188           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3189           (shield_mode.gt.0)) then
3190 !C          print *,i,j
3191           do ilist=1,ishield_list(i)
3192            iresshield=shield_list(ilist,i)
3193            do k=1,3
3194            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3195            *2.0*sss_ele_cut
3196            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3197                    rlocshield &
3198             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3199             *sss_ele_cut
3200             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3201            enddo
3202           enddo
3203           do ilist=1,ishield_list(j)
3204            iresshield=shield_list(ilist,j)
3205            do k=1,3
3206            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3207           *2.0*sss_ele_cut
3208            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3209                    rlocshield &
3210            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3211            *sss_ele_cut
3212            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3213            enddo
3214           enddo
3215           do k=1,3
3216             gshieldc(k,i)=gshieldc(k,i)+ &
3217                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3218            *sss_ele_cut
3219
3220             gshieldc(k,j)=gshieldc(k,j)+ &
3221                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3222            *sss_ele_cut
3223
3224             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3225                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3226            *sss_ele_cut
3227
3228             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3229                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3230            *sss_ele_cut
3231
3232            enddo
3233            endif
3234
3235
3236 !          do k=1,3
3237 !            ghalf=0.5D0*ggg(k)
3238 !            gelc(k,i)=gelc(k,i)+ghalf
3239 !            gelc(k,j)=gelc(k,j)+ghalf
3240 !          enddo
3241 ! 9/28/08 AL Gradient compotents will be summed only at the end
3242           do k=1,3
3243             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3244             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3245           enddo
3246             gelc_long(3,j)=gelc_long(3,j)+  &
3247           ssgradlipj*eesij/2.0d0*lipscale**2&
3248            *sss_ele_cut
3249
3250             gelc_long(3,i)=gelc_long(3,i)+  &
3251           ssgradlipi*eesij/2.0d0*lipscale**2&
3252            *sss_ele_cut
3253
3254
3255 !
3256 ! Loop over residues i+1 thru j-1.
3257 !
3258 !grad          do k=i+1,j-1
3259 !grad            do l=1,3
3260 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3261 !grad            enddo
3262 !grad          enddo
3263           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3264            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3265           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3266            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3267           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3268            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3269
3270 !          do k=1,3
3271 !            ghalf=0.5D0*ggg(k)
3272 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3273 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3274 !          enddo
3275 ! 9/28/08 AL Gradient compotents will be summed only at the end
3276           do k=1,3
3277             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3278             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3279           enddo
3280
3281 !C Lipidic part for scaling weight
3282            gvdwpp(3,j)=gvdwpp(3,j)+ &
3283           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3284            gvdwpp(3,i)=gvdwpp(3,i)+ &
3285           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3286 !! Loop over residues i+1 thru j-1.
3287 !
3288 !grad          do k=i+1,j-1
3289 !grad            do l=1,3
3290 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3291 !grad            enddo
3292 !grad          enddo
3293 #else
3294           facvdw=(ev1+evdwij)*sss_ele_cut &
3295            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3296
3297           facel=(el1+eesij)*sss_ele_cut
3298           fac1=fac
3299           fac=-3*rrmij*(facvdw+facvdw+facel)
3300           erij(1)=xj*rmij
3301           erij(2)=yj*rmij
3302           erij(3)=zj*rmij
3303 !
3304 ! Radial derivatives. First process both termini of the fragment (i,j)
3305 !
3306           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3307           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3308           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3309 !          do k=1,3
3310 !            ghalf=0.5D0*ggg(k)
3311 !            gelc(k,i)=gelc(k,i)+ghalf
3312 !            gelc(k,j)=gelc(k,j)+ghalf
3313 !          enddo
3314 ! 9/28/08 AL Gradient compotents will be summed only at the end
3315           do k=1,3
3316             gelc_long(k,j)=gelc(k,j)+ggg(k)
3317             gelc_long(k,i)=gelc(k,i)-ggg(k)
3318           enddo
3319 !
3320 ! Loop over residues i+1 thru j-1.
3321 !
3322 !grad          do k=i+1,j-1
3323 !grad            do l=1,3
3324 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3325 !grad            enddo
3326 !grad          enddo
3327 ! 9/28/08 AL Gradient compotents will be summed only at the end
3328           ggg(1)=facvdw*xj &
3329            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3330           ggg(2)=facvdw*yj &
3331            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3332           ggg(3)=facvdw*zj &
3333            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3334
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            gvdwpp(3,j)=gvdwpp(3,j)+ &
3340           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3341            gvdwpp(3,i)=gvdwpp(3,i)+ &
3342           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3343
3344 #endif
3345 !
3346 ! Angular part
3347 !
3348           ecosa=2.0D0*fac3*fac1+fac4
3349           fac4=-3.0D0*fac4
3350           fac3=-6.0D0*fac3
3351           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3352           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3353           do k=1,3
3354             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3355             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3356           enddo
3357 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3358 !d   &          (dcosg(k),k=1,3)
3359           do k=1,3
3360             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3361              *fac_shield(i)**2*fac_shield(j)**2 &
3362              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3363
3364           enddo
3365 !          do k=1,3
3366 !            ghalf=0.5D0*ggg(k)
3367 !            gelc(k,i)=gelc(k,i)+ghalf
3368 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3369 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3370 !            gelc(k,j)=gelc(k,j)+ghalf
3371 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3372 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3373 !          enddo
3374 !grad          do k=i+1,j-1
3375 !grad            do l=1,3
3376 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3377 !grad            enddo
3378 !grad          enddo
3379           do k=1,3
3380             gelc(k,i)=gelc(k,i) &
3381                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3382                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3383                      *sss_ele_cut &
3384                      *fac_shield(i)**2*fac_shield(j)**2 &
3385                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3386
3387             gelc(k,j)=gelc(k,j) &
3388                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3389                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3390                      *sss_ele_cut  &
3391                      *fac_shield(i)**2*fac_shield(j)**2  &
3392                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3393
3394             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3395             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3396           enddo
3397
3398           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3399               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3400               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3401 !
3402 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3403 !   energy of a peptide unit is assumed in the form of a second-order
3404 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3405 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3406 !   are computed for EVERY pair of non-contiguous peptide groups.
3407 !
3408           if (j.lt.nres-1) then
3409             j1=j+1
3410             j2=j-1
3411           else
3412             j1=j-1
3413             j2=j-2
3414           endif
3415           kkk=0
3416           do k=1,2
3417             do l=1,2
3418               kkk=kkk+1
3419               muij(kkk)=mu(k,i)*mu(l,j)
3420             enddo
3421           enddo
3422 !d         write (iout,*) 'EELEC: i',i,' j',j
3423 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3424 !d          write(iout,*) 'muij',muij
3425           ury=scalar(uy(1,i),erij)
3426           urz=scalar(uz(1,i),erij)
3427           vry=scalar(uy(1,j),erij)
3428           vrz=scalar(uz(1,j),erij)
3429           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3430           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3431           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3432           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3433           fac=dsqrt(-ael6i)*r3ij
3434           a22=a22*fac
3435           a23=a23*fac
3436           a32=a32*fac
3437           a33=a33*fac
3438 !d          write (iout,'(4i5,4f10.5)')
3439 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3440 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3441 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3442 !d     &      uy(:,j),uz(:,j)
3443 !d          write (iout,'(4f10.5)')
3444 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3445 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3446 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3447 !d           write (iout,'(9f10.5/)')
3448 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3449 ! Derivatives of the elements of A in virtual-bond vectors
3450           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3451           do k=1,3
3452             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3453             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3454             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3455             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3456             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3457             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3458             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3459             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3460             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3461             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3462             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3463             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3464           enddo
3465 ! Compute radial contributions to the gradient
3466           facr=-3.0d0*rrmij
3467           a22der=a22*facr
3468           a23der=a23*facr
3469           a32der=a32*facr
3470           a33der=a33*facr
3471           agg(1,1)=a22der*xj
3472           agg(2,1)=a22der*yj
3473           agg(3,1)=a22der*zj
3474           agg(1,2)=a23der*xj
3475           agg(2,2)=a23der*yj
3476           agg(3,2)=a23der*zj
3477           agg(1,3)=a32der*xj
3478           agg(2,3)=a32der*yj
3479           agg(3,3)=a32der*zj
3480           agg(1,4)=a33der*xj
3481           agg(2,4)=a33der*yj
3482           agg(3,4)=a33der*zj
3483 ! Add the contributions coming from er
3484           fac3=-3.0d0*fac
3485           do k=1,3
3486             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3487             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3488             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3489             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3490           enddo
3491           do k=1,3
3492 ! Derivatives in DC(i)
3493 !grad            ghalf1=0.5d0*agg(k,1)
3494 !grad            ghalf2=0.5d0*agg(k,2)
3495 !grad            ghalf3=0.5d0*agg(k,3)
3496 !grad            ghalf4=0.5d0*agg(k,4)
3497             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3498             -3.0d0*uryg(k,2)*vry)!+ghalf1
3499             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3500             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3501             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3502             -3.0d0*urzg(k,2)*vry)!+ghalf3
3503             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3504             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3505 ! Derivatives in DC(i+1)
3506             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3507             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3508             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3509             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3510             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3511             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3512             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3513             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3514 ! Derivatives in DC(j)
3515             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3516             -3.0d0*vryg(k,2)*ury)!+ghalf1
3517             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3518             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3519             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3520             -3.0d0*vryg(k,2)*urz)!+ghalf3
3521             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3522             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3523 ! Derivatives in DC(j+1) or DC(nres-1)
3524             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3525             -3.0d0*vryg(k,3)*ury)
3526             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3527             -3.0d0*vrzg(k,3)*ury)
3528             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3529             -3.0d0*vryg(k,3)*urz)
3530             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3531             -3.0d0*vrzg(k,3)*urz)
3532 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3533 !grad              do l=1,4
3534 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3535 !grad              enddo
3536 !grad            endif
3537           enddo
3538           acipa(1,1)=a22
3539           acipa(1,2)=a23
3540           acipa(2,1)=a32
3541           acipa(2,2)=a33
3542           a22=-a22
3543           a23=-a23
3544           do l=1,2
3545             do k=1,3
3546               agg(k,l)=-agg(k,l)
3547               aggi(k,l)=-aggi(k,l)
3548               aggi1(k,l)=-aggi1(k,l)
3549               aggj(k,l)=-aggj(k,l)
3550               aggj1(k,l)=-aggj1(k,l)
3551             enddo
3552           enddo
3553           if (j.lt.nres-1) then
3554             a22=-a22
3555             a32=-a32
3556             do l=1,3,2
3557               do k=1,3
3558                 agg(k,l)=-agg(k,l)
3559                 aggi(k,l)=-aggi(k,l)
3560                 aggi1(k,l)=-aggi1(k,l)
3561                 aggj(k,l)=-aggj(k,l)
3562                 aggj1(k,l)=-aggj1(k,l)
3563               enddo
3564             enddo
3565           else
3566             a22=-a22
3567             a23=-a23
3568             a32=-a32
3569             a33=-a33
3570             do l=1,4
3571               do k=1,3
3572                 agg(k,l)=-agg(k,l)
3573                 aggi(k,l)=-aggi(k,l)
3574                 aggi1(k,l)=-aggi1(k,l)
3575                 aggj(k,l)=-aggj(k,l)
3576                 aggj1(k,l)=-aggj1(k,l)
3577               enddo
3578             enddo
3579           endif
3580           ENDIF ! WCORR
3581           IF (wel_loc.gt.0.0d0) THEN
3582 ! Contribution to the local-electrostatic energy coming from the i-j pair
3583           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3584            +a33*muij(4)
3585           if (shield_mode.eq.0) then
3586            fac_shield(i)=1.0
3587            fac_shield(j)=1.0
3588           endif
3589           eel_loc_ij=eel_loc_ij &
3590          *fac_shield(i)*fac_shield(j) &
3591          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3592 !C Now derivative over eel_loc
3593           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3594          (shield_mode.gt.0)) then
3595 !C          print *,i,j
3596
3597           do ilist=1,ishield_list(i)
3598            iresshield=shield_list(ilist,i)
3599            do k=1,3
3600            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3601                                                 /fac_shield(i)&
3602            *sss_ele_cut
3603            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3604                    rlocshield  &
3605           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3606           *sss_ele_cut
3607
3608             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3609            +rlocshield
3610            enddo
3611           enddo
3612           do ilist=1,ishield_list(j)
3613            iresshield=shield_list(ilist,j)
3614            do k=1,3
3615            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3616                                             /fac_shield(j)   &
3617             *sss_ele_cut
3618            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3619                    rlocshield  &
3620       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3621        *sss_ele_cut
3622
3623            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3624                   +rlocshield
3625
3626            enddo
3627           enddo
3628
3629           do k=1,3
3630             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3631                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3632                     *sss_ele_cut
3633             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3634                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3635                     *sss_ele_cut
3636             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3637                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3638                     *sss_ele_cut
3639             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3640                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3641                     *sss_ele_cut
3642
3643            enddo
3644            endif
3645
3646
3647 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3648 !           eel_loc_ij=0.0
3649           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3650                   'eelloc',i,j,eel_loc_ij
3651 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3652 !          if (energy_dec) write (iout,*) "muij",muij
3653 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3654
3655           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3656 ! Partial derivatives in virtual-bond dihedral angles gamma
3657           if (i.gt.1) &
3658           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3659                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3660                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3661                  *sss_ele_cut  &
3662           *fac_shield(i)*fac_shield(j) &
3663           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3664
3665           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3666                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3667                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3668                  *sss_ele_cut &
3669           *fac_shield(i)*fac_shield(j) &
3670           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3671 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3672 !          do l=1,3
3673 !            ggg(1)=(agg(1,1)*muij(1)+ &
3674 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3675 !            *sss_ele_cut &
3676 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3677 !            ggg(2)=(agg(2,1)*muij(1)+ &
3678 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3679 !            *sss_ele_cut &
3680 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3681 !            ggg(3)=(agg(3,1)*muij(1)+ &
3682 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3683 !            *sss_ele_cut &
3684 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3685            xtemp(1)=xj
3686            xtemp(2)=yj
3687            xtemp(3)=zj
3688
3689            do l=1,3
3690             ggg(l)=(agg(l,1)*muij(1)+ &
3691                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3692             *sss_ele_cut &
3693           *fac_shield(i)*fac_shield(j) &
3694           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
3695              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3696
3697
3698             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3699             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3700 !grad            ghalf=0.5d0*ggg(l)
3701 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3702 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3703           enddo
3704             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
3705           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
3706           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3707
3708             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
3709           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
3710           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3711
3712 !grad          do k=i+1,j2
3713 !grad            do l=1,3
3714 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3715 !grad            enddo
3716 !grad          enddo
3717 ! Remaining derivatives of eello
3718           do l=1,3
3719             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
3720                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
3721             *sss_ele_cut &
3722           *fac_shield(i)*fac_shield(j) &
3723           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3724
3725 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3726             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
3727                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
3728             +aggi1(l,4)*muij(4))&
3729             *sss_ele_cut &
3730           *fac_shield(i)*fac_shield(j) &
3731           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3732
3733 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3734             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
3735                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
3736             *sss_ele_cut &
3737           *fac_shield(i)*fac_shield(j) &
3738           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3739
3740 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3741             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
3742                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
3743             +aggj1(l,4)*muij(4))&
3744             *sss_ele_cut &
3745           *fac_shield(i)*fac_shield(j) &
3746           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3747
3748 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3749           enddo
3750           ENDIF
3751 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3752 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3753           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3754              .and. num_conti.le.maxconts) then
3755 !            write (iout,*) i,j," entered corr"
3756 !
3757 ! Calculate the contact function. The ith column of the array JCONT will
3758 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3759 ! greater than I). The arrays FACONT and GACONT will contain the values of
3760 ! the contact function and its derivative.
3761 !           r0ij=1.02D0*rpp(iteli,itelj)
3762 !           r0ij=1.11D0*rpp(iteli,itelj)
3763             r0ij=2.20D0*rpp(iteli,itelj)
3764 !           r0ij=1.55D0*rpp(iteli,itelj)
3765             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3766 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3767             if (fcont.gt.0.0D0) then
3768               num_conti=num_conti+1
3769               if (num_conti.gt.maxconts) then
3770 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3771 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3772                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3773                                ' will skip next contacts for this conf.', num_conti
3774               else
3775                 jcont_hb(num_conti,i)=j
3776 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3777 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3778                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3779                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3780 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3781 !  terms.
3782                 d_cont(num_conti,i)=rij
3783 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3784 !     --- Electrostatic-interaction matrix ---
3785                 a_chuj(1,1,num_conti,i)=a22
3786                 a_chuj(1,2,num_conti,i)=a23
3787                 a_chuj(2,1,num_conti,i)=a32
3788                 a_chuj(2,2,num_conti,i)=a33
3789 !     --- Gradient of rij
3790                 do kkk=1,3
3791                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3792                 enddo
3793                 kkll=0
3794                 do k=1,2
3795                   do l=1,2
3796                     kkll=kkll+1
3797                     do m=1,3
3798                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3799                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3800                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3801                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3802                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3803                     enddo
3804                   enddo
3805                 enddo
3806                 ENDIF
3807                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3808 ! Calculate contact energies
3809                 cosa4=4.0D0*cosa
3810                 wij=cosa-3.0D0*cosb*cosg
3811                 cosbg1=cosb+cosg
3812                 cosbg2=cosb-cosg
3813 !               fac3=dsqrt(-ael6i)/r0ij**3
3814                 fac3=dsqrt(-ael6i)*r3ij
3815 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3816                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3817                 if (ees0tmp.gt.0) then
3818                   ees0pij=dsqrt(ees0tmp)
3819                 else
3820                   ees0pij=0
3821                 endif
3822                 if (shield_mode.eq.0) then
3823                 fac_shield(i)=1.0d0
3824                 fac_shield(j)=1.0d0
3825                 else
3826                 ees0plist(num_conti,i)=j
3827                 endif
3828 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3829                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3830                 if (ees0tmp.gt.0) then
3831                   ees0mij=dsqrt(ees0tmp)
3832                 else
3833                   ees0mij=0
3834                 endif
3835 !               ees0mij=0.0D0
3836                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
3837                      *sss_ele_cut &
3838                      *fac_shield(i)*fac_shield(j)
3839
3840                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
3841                      *sss_ele_cut &
3842                      *fac_shield(i)*fac_shield(j)
3843
3844 ! Diagnostics. Comment out or remove after debugging!
3845 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3846 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3847 !               ees0m(num_conti,i)=0.0D0
3848 ! End diagnostics.
3849 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3850 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3851 ! Angular derivatives of the contact function
3852                 ees0pij1=fac3/ees0pij
3853                 ees0mij1=fac3/ees0mij
3854                 fac3p=-3.0D0*fac3*rrmij
3855                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3856                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3857 !               ees0mij1=0.0D0
3858                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3859                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3860                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3861                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3862                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3863                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3864                 ecosap=ecosa1+ecosa2
3865                 ecosbp=ecosb1+ecosb2
3866                 ecosgp=ecosg1+ecosg2
3867                 ecosam=ecosa1-ecosa2
3868                 ecosbm=ecosb1-ecosb2
3869                 ecosgm=ecosg1-ecosg2
3870 ! Diagnostics
3871 !               ecosap=ecosa1
3872 !               ecosbp=ecosb1
3873 !               ecosgp=ecosg1
3874 !               ecosam=0.0D0
3875 !               ecosbm=0.0D0
3876 !               ecosgm=0.0D0
3877 ! End diagnostics
3878                 facont_hb(num_conti,i)=fcont
3879                 fprimcont=fprimcont/rij
3880 !d              facont_hb(num_conti,i)=1.0D0
3881 ! Following line is for diagnostics.
3882 !d              fprimcont=0.0D0
3883                 do k=1,3
3884                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3885                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3886                 enddo
3887                 do k=1,3
3888                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3889                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3890                 enddo
3891                 gggp(1)=gggp(1)+ees0pijp*xj &
3892                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3893                 gggp(2)=gggp(2)+ees0pijp*yj &
3894                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3895                 gggp(3)=gggp(3)+ees0pijp*zj &
3896                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3897
3898                 gggm(1)=gggm(1)+ees0mijp*xj &
3899                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3900
3901                 gggm(2)=gggm(2)+ees0mijp*yj &
3902                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3903
3904                 gggm(3)=gggm(3)+ees0mijp*zj &
3905                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3906
3907 ! Derivatives due to the contact function
3908                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3909                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3910                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3911                 do k=1,3
3912 !
3913 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3914 !          following the change of gradient-summation algorithm.
3915 !
3916 !grad                  ghalfp=0.5D0*gggp(k)
3917 !grad                  ghalfm=0.5D0*gggm(k)
3918                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3919                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3920                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3921                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3922
3923                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3924                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3925                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3926                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3927
3928                   gacontp_hb3(k,num_conti,i)=gggp(k) &
3929                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3930
3931                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3932                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3933                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3934                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3935
3936                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3937                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3938                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
3939                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3940
3941                   gacontm_hb3(k,num_conti,i)=gggm(k) &
3942                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3943
3944                 enddo
3945 ! Diagnostics. Comment out or remove after debugging!
3946 !diag           do k=1,3
3947 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
3948 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
3949 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
3950 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
3951 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
3952 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
3953 !diag           enddo
3954               ENDIF ! wcorr
3955               endif  ! num_conti.le.maxconts
3956             endif  ! fcont.gt.0
3957           endif    ! j.gt.i+1
3958           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3959             do k=1,4
3960               do l=1,3
3961                 ghalf=0.5d0*agg(l,k)
3962                 aggi(l,k)=aggi(l,k)+ghalf
3963                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3964                 aggj(l,k)=aggj(l,k)+ghalf
3965               enddo
3966             enddo
3967             if (j.eq.nres-1 .and. i.lt.j-2) then
3968               do k=1,4
3969                 do l=1,3
3970                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3971                 enddo
3972               enddo
3973             endif
3974           endif
3975  128  continue
3976 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
3977       return
3978       end subroutine eelecij
3979 !-----------------------------------------------------------------------------
3980       subroutine eturn3(i,eello_turn3)
3981 ! Third- and fourth-order contributions from turns
3982
3983       use comm_locel
3984 !      implicit real*8 (a-h,o-z)
3985 !      include 'DIMENSIONS'
3986 !      include 'COMMON.IOUNITS'
3987 !      include 'COMMON.GEO'
3988 !      include 'COMMON.VAR'
3989 !      include 'COMMON.LOCAL'
3990 !      include 'COMMON.CHAIN'
3991 !      include 'COMMON.DERIV'
3992 !      include 'COMMON.INTERACT'
3993 !      include 'COMMON.CONTACTS'
3994 !      include 'COMMON.TORSION'
3995 !      include 'COMMON.VECTORS'
3996 !      include 'COMMON.FFIELD'
3997 !      include 'COMMON.CONTROL'
3998       real(kind=8),dimension(3) :: ggg
3999       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4000         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4001       real(kind=8),dimension(2) :: auxvec,auxvec1
4002 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4003       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4004 !el      integer :: num_conti,j1,j2
4005 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4006 !el        dz_normi,xmedi,ymedi,zmedi
4007
4008 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4009 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4010 !el         num_conti,j1,j2
4011 !el local variables
4012       integer :: i,j,l,k,ilist,iresshield
4013       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4014
4015       j=i+2
4016 !      write (iout,*) "eturn3",i,j,j1,j2
4017           zj=(c(3,j)+c(3,j+1))/2.0d0
4018           zj=mod(zj,boxzsize)
4019           if (zj.lt.0) zj=zj+boxzsize
4020           if ((zj.lt.0)) write (*,*) "CHUJ"
4021        if ((zj.gt.bordlipbot)  &
4022         .and.(zj.lt.bordliptop)) then
4023 !C the energy transfer exist
4024         if (zj.lt.buflipbot) then
4025 !C what fraction I am in
4026          fracinbuf=1.0d0-     &
4027              ((zj-bordlipbot)/lipbufthick)
4028 !C lipbufthick is thickenes of lipid buffore
4029          sslipj=sscalelip(fracinbuf)
4030          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4031         elseif (zj.gt.bufliptop) then
4032          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4033          sslipj=sscalelip(fracinbuf)
4034          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4035         else
4036          sslipj=1.0d0
4037          ssgradlipj=0.0
4038         endif
4039        else
4040          sslipj=0.0d0
4041          ssgradlipj=0.0
4042        endif
4043
4044       a_temp(1,1)=a22
4045       a_temp(1,2)=a23
4046       a_temp(2,1)=a32
4047       a_temp(2,2)=a33
4048 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4049 !
4050 !               Third-order contributions
4051 !
4052 !                 (i+2)o----(i+3)
4053 !                      | |
4054 !                      | |
4055 !                 (i+1)o----i
4056 !
4057 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4058 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4059         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4060         call transpose2(auxmat(1,1),auxmat1(1,1))
4061         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4062         if (shield_mode.eq.0) then
4063         fac_shield(i)=1.0d0
4064         fac_shield(j)=1.0d0
4065         endif
4066
4067         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4068          *fac_shield(i)*fac_shield(j)  &
4069          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4070         eello_t3= &
4071         0.5d0*(pizda(1,1)+pizda(2,2)) &
4072         *fac_shield(i)*fac_shield(j)
4073
4074         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4075                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4076           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4077        (shield_mode.gt.0)) then
4078 !C          print *,i,j
4079
4080           do ilist=1,ishield_list(i)
4081            iresshield=shield_list(ilist,i)
4082            do k=1,3
4083            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4084            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4085                    rlocshield &
4086            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4087             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4088              +rlocshield
4089            enddo
4090           enddo
4091           do ilist=1,ishield_list(j)
4092            iresshield=shield_list(ilist,j)
4093            do k=1,3
4094            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4095            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4096                    rlocshield &
4097            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4098            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4099                   +rlocshield
4100
4101            enddo
4102           enddo
4103
4104           do k=1,3
4105             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4106                    grad_shield(k,i)*eello_t3/fac_shield(i)
4107             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4108                    grad_shield(k,j)*eello_t3/fac_shield(j)
4109             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4110                    grad_shield(k,i)*eello_t3/fac_shield(i)
4111             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4112                    grad_shield(k,j)*eello_t3/fac_shield(j)
4113            enddo
4114            endif
4115
4116 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4117 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4118 !d     &    ' eello_turn3_num',4*eello_turn3_num
4119 ! Derivatives in gamma(i)
4120         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4121         call transpose2(auxmat2(1,1),auxmat3(1,1))
4122         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4123         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4124           *fac_shield(i)*fac_shield(j)        &
4125           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4126 ! Derivatives in gamma(i+1)
4127         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4128         call transpose2(auxmat2(1,1),auxmat3(1,1))
4129         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4130         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4131           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4132           *fac_shield(i)*fac_shield(j)        &
4133           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4134
4135 ! Cartesian derivatives
4136         do l=1,3
4137 !            ghalf1=0.5d0*agg(l,1)
4138 !            ghalf2=0.5d0*agg(l,2)
4139 !            ghalf3=0.5d0*agg(l,3)
4140 !            ghalf4=0.5d0*agg(l,4)
4141           a_temp(1,1)=aggi(l,1)!+ghalf1
4142           a_temp(1,2)=aggi(l,2)!+ghalf2
4143           a_temp(2,1)=aggi(l,3)!+ghalf3
4144           a_temp(2,2)=aggi(l,4)!+ghalf4
4145           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4146           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4147             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4148           *fac_shield(i)*fac_shield(j)      &
4149           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4150
4151           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4152           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4153           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4154           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4155           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4156           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4157             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4158           *fac_shield(i)*fac_shield(j)        &
4159           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4160
4161           a_temp(1,1)=aggj(l,1)!+ghalf1
4162           a_temp(1,2)=aggj(l,2)!+ghalf2
4163           a_temp(2,1)=aggj(l,3)!+ghalf3
4164           a_temp(2,2)=aggj(l,4)!+ghalf4
4165           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4166           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4167             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4168           *fac_shield(i)*fac_shield(j)      &
4169           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4170
4171           a_temp(1,1)=aggj1(l,1)
4172           a_temp(1,2)=aggj1(l,2)
4173           a_temp(2,1)=aggj1(l,3)
4174           a_temp(2,2)=aggj1(l,4)
4175           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4176           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4177             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4178           *fac_shield(i)*fac_shield(j)        &
4179           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4180         enddo
4181          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4182           ssgradlipi*eello_t3/4.0d0*lipscale
4183          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4184           ssgradlipj*eello_t3/4.0d0*lipscale
4185          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4186           ssgradlipi*eello_t3/4.0d0*lipscale
4187          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4188           ssgradlipj*eello_t3/4.0d0*lipscale
4189
4190       return
4191       end subroutine eturn3
4192 !-----------------------------------------------------------------------------
4193       subroutine eturn4(i,eello_turn4)
4194 ! Third- and fourth-order contributions from turns
4195
4196       use comm_locel
4197 !      implicit real*8 (a-h,o-z)
4198 !      include 'DIMENSIONS'
4199 !      include 'COMMON.IOUNITS'
4200 !      include 'COMMON.GEO'
4201 !      include 'COMMON.VAR'
4202 !      include 'COMMON.LOCAL'
4203 !      include 'COMMON.CHAIN'
4204 !      include 'COMMON.DERIV'
4205 !      include 'COMMON.INTERACT'
4206 !      include 'COMMON.CONTACTS'
4207 !      include 'COMMON.TORSION'
4208 !      include 'COMMON.VECTORS'
4209 !      include 'COMMON.FFIELD'
4210 !      include 'COMMON.CONTROL'
4211       real(kind=8),dimension(3) :: ggg
4212       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4213         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4214       real(kind=8),dimension(2) :: auxvec,auxvec1
4215 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4216       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4217 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4218 !el        dz_normi,xmedi,ymedi,zmedi
4219 !el      integer :: num_conti,j1,j2
4220 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4221 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4222 !el          num_conti,j1,j2
4223 !el local variables
4224       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4225       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4226          rlocshield
4227
4228       j=i+3
4229 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4230 !
4231 !               Fourth-order contributions
4232 !
4233 !                 (i+3)o----(i+4)
4234 !                     /  |
4235 !               (i+2)o   |
4236 !                     \  |
4237 !                 (i+1)o----i
4238 !
4239 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4240 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4241 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4242           zj=(c(3,j)+c(3,j+1))/2.0d0
4243           zj=mod(zj,boxzsize)
4244           if (zj.lt.0) zj=zj+boxzsize
4245        if ((zj.gt.bordlipbot)  &
4246         .and.(zj.lt.bordliptop)) then
4247 !C the energy transfer exist
4248         if (zj.lt.buflipbot) then
4249 !C what fraction I am in
4250          fracinbuf=1.0d0-     &
4251              ((zj-bordlipbot)/lipbufthick)
4252 !C lipbufthick is thickenes of lipid buffore
4253          sslipj=sscalelip(fracinbuf)
4254          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4255         elseif (zj.gt.bufliptop) then
4256          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4257          sslipj=sscalelip(fracinbuf)
4258          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4259         else
4260          sslipj=1.0d0
4261          ssgradlipj=0.0
4262         endif
4263        else
4264          sslipj=0.0d0
4265          ssgradlipj=0.0
4266        endif
4267
4268         a_temp(1,1)=a22
4269         a_temp(1,2)=a23
4270         a_temp(2,1)=a32
4271         a_temp(2,2)=a33
4272         iti1=itortyp(itype(i+1))
4273         iti2=itortyp(itype(i+2))
4274         iti3=itortyp(itype(i+3))
4275 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4276         call transpose2(EUg(1,1,i+1),e1t(1,1))
4277         call transpose2(Eug(1,1,i+2),e2t(1,1))
4278         call transpose2(Eug(1,1,i+3),e3t(1,1))
4279         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4280         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4281         s1=scalar2(b1(1,iti2),auxvec(1))
4282         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4283         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4284         s2=scalar2(b1(1,iti1),auxvec(1))
4285         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4286         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4287         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4288         if (shield_mode.eq.0) then
4289         fac_shield(i)=1.0
4290         fac_shield(j)=1.0
4291         endif
4292
4293         eello_turn4=eello_turn4-(s1+s2+s3) &
4294         *fac_shield(i)*fac_shield(j)       &
4295         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4296         eello_t4=-(s1+s2+s3)  &
4297           *fac_shield(i)*fac_shield(j)
4298 !C Now derivative over shield:
4299           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4300          (shield_mode.gt.0)) then
4301 !C          print *,i,j
4302
4303           do ilist=1,ishield_list(i)
4304            iresshield=shield_list(ilist,i)
4305            do k=1,3
4306            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4307            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4308                    rlocshield &
4309             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4310             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4311            +rlocshield
4312            enddo
4313           enddo
4314           do ilist=1,ishield_list(j)
4315            iresshield=shield_list(ilist,j)
4316            do k=1,3
4317            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4318            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4319                    rlocshield  &
4320            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4321            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4322                   +rlocshield
4323
4324            enddo
4325           enddo
4326
4327           do k=1,3
4328             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4329                    grad_shield(k,i)*eello_t4/fac_shield(i)
4330             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4331                    grad_shield(k,j)*eello_t4/fac_shield(j)
4332             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4333                    grad_shield(k,i)*eello_t4/fac_shield(i)
4334             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4335                    grad_shield(k,j)*eello_t4/fac_shield(j)
4336            enddo
4337            endif
4338
4339         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4340            'eturn4',i,j,-(s1+s2+s3)
4341 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4342 !d     &    ' eello_turn4_num',8*eello_turn4_num
4343 ! Derivatives in gamma(i)
4344         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4345         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4346         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4347         s1=scalar2(b1(1,iti2),auxvec(1))
4348         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4349         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4350         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4351        *fac_shield(i)*fac_shield(j)  &
4352        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4353
4354 ! Derivatives in gamma(i+1)
4355         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4356         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4357         s2=scalar2(b1(1,iti1),auxvec(1))
4358         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4359         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4360         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4361         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4362        *fac_shield(i)*fac_shield(j)  &
4363        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4364
4365 ! Derivatives in gamma(i+2)
4366         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4367         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4368         s1=scalar2(b1(1,iti2),auxvec(1))
4369         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4370         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4371         s2=scalar2(b1(1,iti1),auxvec(1))
4372         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4373         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4374         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4375         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4376        *fac_shield(i)*fac_shield(j)  &
4377        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4378
4379 ! Cartesian derivatives
4380 ! Derivatives of this turn contributions in DC(i+2)
4381         if (j.lt.nres-1) then
4382           do l=1,3
4383             a_temp(1,1)=agg(l,1)
4384             a_temp(1,2)=agg(l,2)
4385             a_temp(2,1)=agg(l,3)
4386             a_temp(2,2)=agg(l,4)
4387             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4388             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4389             s1=scalar2(b1(1,iti2),auxvec(1))
4390             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4391             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4392             s2=scalar2(b1(1,iti1),auxvec(1))
4393             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4394             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4395             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4396             ggg(l)=-(s1+s2+s3)
4397             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4398        *fac_shield(i)*fac_shield(j)  &
4399        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4400
4401           enddo
4402         endif
4403 ! Remaining derivatives of this turn contribution
4404         do l=1,3
4405           a_temp(1,1)=aggi(l,1)
4406           a_temp(1,2)=aggi(l,2)
4407           a_temp(2,1)=aggi(l,3)
4408           a_temp(2,2)=aggi(l,4)
4409           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4410           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4411           s1=scalar2(b1(1,iti2),auxvec(1))
4412           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4413           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4414           s2=scalar2(b1(1,iti1),auxvec(1))
4415           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4416           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4417           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4418           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4419          *fac_shield(i)*fac_shield(j)  &
4420          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4421
4422
4423           a_temp(1,1)=aggi1(l,1)
4424           a_temp(1,2)=aggi1(l,2)
4425           a_temp(2,1)=aggi1(l,3)
4426           a_temp(2,2)=aggi1(l,4)
4427           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4428           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4429           s1=scalar2(b1(1,iti2),auxvec(1))
4430           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4431           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4432           s2=scalar2(b1(1,iti1),auxvec(1))
4433           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4434           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4435           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4436           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4437          *fac_shield(i)*fac_shield(j)  &
4438          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4439
4440
4441           a_temp(1,1)=aggj(l,1)
4442           a_temp(1,2)=aggj(l,2)
4443           a_temp(2,1)=aggj(l,3)
4444           a_temp(2,2)=aggj(l,4)
4445           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4446           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4447           s1=scalar2(b1(1,iti2),auxvec(1))
4448           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4449           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4450           s2=scalar2(b1(1,iti1),auxvec(1))
4451           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4452           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4453           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4454           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4455          *fac_shield(i)*fac_shield(j)  &
4456          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4457
4458
4459           a_temp(1,1)=aggj1(l,1)
4460           a_temp(1,2)=aggj1(l,2)
4461           a_temp(2,1)=aggj1(l,3)
4462           a_temp(2,2)=aggj1(l,4)
4463           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4464           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4465           s1=scalar2(b1(1,iti2),auxvec(1))
4466           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4467           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4468           s2=scalar2(b1(1,iti1),auxvec(1))
4469           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4470           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4471           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4472 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4473           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4474          *fac_shield(i)*fac_shield(j)  &
4475          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4476
4477         enddo
4478          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4479           ssgradlipi*eello_t4/4.0d0*lipscale
4480          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4481           ssgradlipj*eello_t4/4.0d0*lipscale
4482          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4483           ssgradlipi*eello_t4/4.0d0*lipscale
4484          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4485           ssgradlipj*eello_t4/4.0d0*lipscale
4486
4487       return
4488       end subroutine eturn4
4489 !-----------------------------------------------------------------------------
4490       subroutine unormderiv(u,ugrad,unorm,ungrad)
4491 ! This subroutine computes the derivatives of a normalized vector u, given
4492 ! the derivatives computed without normalization conditions, ugrad. Returns
4493 ! ungrad.
4494 !      implicit none
4495       real(kind=8),dimension(3) :: u,vec
4496       real(kind=8),dimension(3,3) ::ugrad,ungrad
4497       real(kind=8) :: unorm     !,scalar
4498       integer :: i,j
4499 !      write (2,*) 'ugrad',ugrad
4500 !      write (2,*) 'u',u
4501       do i=1,3
4502         vec(i)=scalar(ugrad(1,i),u(1))
4503       enddo
4504 !      write (2,*) 'vec',vec
4505       do i=1,3
4506         do j=1,3
4507           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4508         enddo
4509       enddo
4510 !      write (2,*) 'ungrad',ungrad
4511       return
4512       end subroutine unormderiv
4513 !-----------------------------------------------------------------------------
4514       subroutine escp_soft_sphere(evdw2,evdw2_14)
4515 !
4516 ! This subroutine calculates the excluded-volume interaction energy between
4517 ! peptide-group centers and side chains and its gradient in virtual-bond and
4518 ! side-chain vectors.
4519 !
4520 !      implicit real*8 (a-h,o-z)
4521 !      include 'DIMENSIONS'
4522 !      include 'COMMON.GEO'
4523 !      include 'COMMON.VAR'
4524 !      include 'COMMON.LOCAL'
4525 !      include 'COMMON.CHAIN'
4526 !      include 'COMMON.DERIV'
4527 !      include 'COMMON.INTERACT'
4528 !      include 'COMMON.FFIELD'
4529 !      include 'COMMON.IOUNITS'
4530 !      include 'COMMON.CONTROL'
4531       real(kind=8),dimension(3) :: ggg
4532 !el local variables
4533       integer :: i,iint,j,k,iteli,itypj
4534       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4535                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4536
4537       evdw2=0.0D0
4538       evdw2_14=0.0d0
4539       r0_scp=4.5d0
4540 !d    print '(a)','Enter ESCP'
4541 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4542       do i=iatscp_s,iatscp_e
4543         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4544         iteli=itel(i)
4545         xi=0.5D0*(c(1,i)+c(1,i+1))
4546         yi=0.5D0*(c(2,i)+c(2,i+1))
4547         zi=0.5D0*(c(3,i)+c(3,i+1))
4548
4549         do iint=1,nscp_gr(i)
4550
4551         do j=iscpstart(i,iint),iscpend(i,iint)
4552           if (itype(j).eq.ntyp1) cycle
4553           itypj=iabs(itype(j))
4554 ! Uncomment following three lines for SC-p interactions
4555 !         xj=c(1,nres+j)-xi
4556 !         yj=c(2,nres+j)-yi
4557 !         zj=c(3,nres+j)-zi
4558 ! Uncomment following three lines for Ca-p interactions
4559           xj=c(1,j)-xi
4560           yj=c(2,j)-yi
4561           zj=c(3,j)-zi
4562           rij=xj*xj+yj*yj+zj*zj
4563           r0ij=r0_scp
4564           r0ijsq=r0ij*r0ij
4565           if (rij.lt.r0ijsq) then
4566             evdwij=0.25d0*(rij-r0ijsq)**2
4567             fac=rij-r0ijsq
4568           else
4569             evdwij=0.0d0
4570             fac=0.0d0
4571           endif
4572           evdw2=evdw2+evdwij
4573 !
4574 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4575 !
4576           ggg(1)=xj*fac
4577           ggg(2)=yj*fac
4578           ggg(3)=zj*fac
4579 !grad          if (j.lt.i) then
4580 !d          write (iout,*) 'j<i'
4581 ! Uncomment following three lines for SC-p interactions
4582 !           do k=1,3
4583 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4584 !           enddo
4585 !grad          else
4586 !d          write (iout,*) 'j>i'
4587 !grad            do k=1,3
4588 !grad              ggg(k)=-ggg(k)
4589 ! Uncomment following line for SC-p interactions
4590 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4591 !grad            enddo
4592 !grad          endif
4593 !grad          do k=1,3
4594 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4595 !grad          enddo
4596 !grad          kstart=min0(i+1,j)
4597 !grad          kend=max0(i-1,j-1)
4598 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4599 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4600 !grad          do k=kstart,kend
4601 !grad            do l=1,3
4602 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4603 !grad            enddo
4604 !grad          enddo
4605           do k=1,3
4606             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4607             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4608           enddo
4609         enddo
4610
4611         enddo ! iint
4612       enddo ! i
4613       return
4614       end subroutine escp_soft_sphere
4615 !-----------------------------------------------------------------------------
4616       subroutine escp(evdw2,evdw2_14)
4617 !
4618 ! This subroutine calculates the excluded-volume interaction energy between
4619 ! peptide-group centers and side chains and its gradient in virtual-bond and
4620 ! side-chain vectors.
4621 !
4622 !      implicit real*8 (a-h,o-z)
4623 !      include 'DIMENSIONS'
4624 !      include 'COMMON.GEO'
4625 !      include 'COMMON.VAR'
4626 !      include 'COMMON.LOCAL'
4627 !      include 'COMMON.CHAIN'
4628 !      include 'COMMON.DERIV'
4629 !      include 'COMMON.INTERACT'
4630 !      include 'COMMON.FFIELD'
4631 !      include 'COMMON.IOUNITS'
4632 !      include 'COMMON.CONTROL'
4633       real(kind=8),dimension(3) :: ggg
4634 !el local variables
4635       integer :: i,iint,j,k,iteli,itypj,subchap
4636       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4637                    e1,e2,evdwij,rij
4638       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4639                     dist_temp, dist_init
4640       integer xshift,yshift,zshift
4641
4642       evdw2=0.0D0
4643       evdw2_14=0.0d0
4644 !d    print '(a)','Enter ESCP'
4645 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4646       do i=iatscp_s,iatscp_e
4647         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4648         iteli=itel(i)
4649         xi=0.5D0*(c(1,i)+c(1,i+1))
4650         yi=0.5D0*(c(2,i)+c(2,i+1))
4651         zi=0.5D0*(c(3,i)+c(3,i+1))
4652           xi=mod(xi,boxxsize)
4653           if (xi.lt.0) xi=xi+boxxsize
4654           yi=mod(yi,boxysize)
4655           if (yi.lt.0) yi=yi+boxysize
4656           zi=mod(zi,boxzsize)
4657           if (zi.lt.0) zi=zi+boxzsize
4658
4659         do iint=1,nscp_gr(i)
4660
4661         do j=iscpstart(i,iint),iscpend(i,iint)
4662           itypj=iabs(itype(j))
4663           if (itypj.eq.ntyp1) cycle
4664 ! Uncomment following three lines for SC-p interactions
4665 !         xj=c(1,nres+j)-xi
4666 !         yj=c(2,nres+j)-yi
4667 !         zj=c(3,nres+j)-zi
4668 ! Uncomment following three lines for Ca-p interactions
4669 !          xj=c(1,j)-xi
4670 !          yj=c(2,j)-yi
4671 !          zj=c(3,j)-zi
4672           xj=c(1,j)
4673           yj=c(2,j)
4674           zj=c(3,j)
4675           xj=mod(xj,boxxsize)
4676           if (xj.lt.0) xj=xj+boxxsize
4677           yj=mod(yj,boxysize)
4678           if (yj.lt.0) yj=yj+boxysize
4679           zj=mod(zj,boxzsize)
4680           if (zj.lt.0) zj=zj+boxzsize
4681       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4682       xj_safe=xj
4683       yj_safe=yj
4684       zj_safe=zj
4685       subchap=0
4686       do xshift=-1,1
4687       do yshift=-1,1
4688       do zshift=-1,1
4689           xj=xj_safe+xshift*boxxsize
4690           yj=yj_safe+yshift*boxysize
4691           zj=zj_safe+zshift*boxzsize
4692           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4693           if(dist_temp.lt.dist_init) then
4694             dist_init=dist_temp
4695             xj_temp=xj
4696             yj_temp=yj
4697             zj_temp=zj
4698             subchap=1
4699           endif
4700        enddo
4701        enddo
4702        enddo
4703        if (subchap.eq.1) then
4704           xj=xj_temp-xi
4705           yj=yj_temp-yi
4706           zj=zj_temp-zi
4707        else
4708           xj=xj_safe-xi
4709           yj=yj_safe-yi
4710           zj=zj_safe-zi
4711        endif
4712
4713           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4714           rij=dsqrt(1.0d0/rrij)
4715             sss_ele_cut=sscale_ele(rij)
4716             sss_ele_grad=sscagrad_ele(rij)
4717 !            print *,sss_ele_cut,sss_ele_grad,&
4718 !            (rij),r_cut_ele,rlamb_ele
4719             if (sss_ele_cut.le.0.0) cycle
4720           fac=rrij**expon2
4721           e1=fac*fac*aad(itypj,iteli)
4722           e2=fac*bad(itypj,iteli)
4723           if (iabs(j-i) .le. 2) then
4724             e1=scal14*e1
4725             e2=scal14*e2
4726             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
4727           endif
4728           evdwij=e1+e2
4729           evdw2=evdw2+evdwij*sss_ele_cut
4730 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
4731 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
4732           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4733              'evdw2',i,j,evdwij
4734 !
4735 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4736 !
4737           fac=-(evdwij+e1)*rrij*sss_ele_cut
4738           fac=fac+evdwij*sss_ele_grad/rij/expon
4739           ggg(1)=xj*fac
4740           ggg(2)=yj*fac
4741           ggg(3)=zj*fac
4742 !grad          if (j.lt.i) then
4743 !d          write (iout,*) 'j<i'
4744 ! Uncomment following three lines for SC-p interactions
4745 !           do k=1,3
4746 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4747 !           enddo
4748 !grad          else
4749 !d          write (iout,*) 'j>i'
4750 !grad            do k=1,3
4751 !grad              ggg(k)=-ggg(k)
4752 ! Uncomment following line for SC-p interactions
4753 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4754 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4755 !grad            enddo
4756 !grad          endif
4757 !grad          do k=1,3
4758 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4759 !grad          enddo
4760 !grad          kstart=min0(i+1,j)
4761 !grad          kend=max0(i-1,j-1)
4762 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4763 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4764 !grad          do k=kstart,kend
4765 !grad            do l=1,3
4766 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4767 !grad            enddo
4768 !grad          enddo
4769           do k=1,3
4770             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4771             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4772           enddo
4773         enddo
4774
4775         enddo ! iint
4776       enddo ! i
4777       do i=1,nct
4778         do j=1,3
4779           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4780           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4781           gradx_scp(j,i)=expon*gradx_scp(j,i)
4782         enddo
4783       enddo
4784 !******************************************************************************
4785 !
4786 !                              N O T E !!!
4787 !
4788 ! To save time the factor EXPON has been extracted from ALL components
4789 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
4790 ! use!
4791 !
4792 !******************************************************************************
4793       return
4794       end subroutine escp
4795 !-----------------------------------------------------------------------------
4796       subroutine edis(ehpb)
4797 !
4798 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4799 !
4800 !      implicit real*8 (a-h,o-z)
4801 !      include 'DIMENSIONS'
4802 !      include 'COMMON.SBRIDGE'
4803 !      include 'COMMON.CHAIN'
4804 !      include 'COMMON.DERIV'
4805 !      include 'COMMON.VAR'
4806 !      include 'COMMON.INTERACT'
4807 !      include 'COMMON.IOUNITS'
4808       real(kind=8),dimension(3) :: ggg
4809 !el local variables
4810       integer :: i,j,ii,jj,iii,jjj,k
4811       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
4812
4813       ehpb=0.0D0
4814 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4815 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
4816       if (link_end.eq.0) return
4817       do i=link_start,link_end
4818 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4819 ! CA-CA distance used in regularization of structure.
4820         ii=ihpb(i)
4821         jj=jhpb(i)
4822 ! iii and jjj point to the residues for which the distance is assigned.
4823         if (ii.gt.nres) then
4824           iii=ii-nres
4825           jjj=jj-nres
4826         else
4827           iii=ii
4828           jjj=jj
4829         endif
4830 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4831 !     &    dhpb(i),dhpb1(i),forcon(i)
4832 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
4833 !    distance and angle dependent SS bond potential.
4834 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4835 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4836         if (.not.dyn_ss .and. i.le.nss) then
4837 ! 15/02/13 CC dynamic SSbond - additional check
4838          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. &
4839         iabs(itype(jjj)).eq.1) then
4840           call ssbond_ene(iii,jjj,eij)
4841           ehpb=ehpb+2*eij
4842 !d          write (iout,*) "eij",eij
4843          endif
4844         else
4845 ! Calculate the distance between the two points and its difference from the
4846 ! target distance.
4847         dd=dist(ii,jj)
4848         rdis=dd-dhpb(i)
4849 ! Get the force constant corresponding to this distance.
4850         waga=forcon(i)
4851 ! Calculate the contribution to energy.
4852         ehpb=ehpb+waga*rdis*rdis
4853 !
4854 ! Evaluate gradient.
4855 !
4856         fac=waga*rdis/dd
4857 !d      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4858 !d   &   ' waga=',waga,' fac=',fac
4859         do j=1,3
4860           ggg(j)=fac*(c(j,jj)-c(j,ii))
4861         enddo
4862 !d      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4863 ! If this is a SC-SC distance, we need to calculate the contributions to the
4864 ! Cartesian gradient in the SC vectors (ghpbx).
4865         if (iii.lt.ii) then
4866           do j=1,3
4867             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4868             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4869           enddo
4870         endif
4871 !grad        do j=iii,jjj-1
4872 !grad          do k=1,3
4873 !grad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4874 !grad          enddo
4875 !grad        enddo
4876         do k=1,3
4877           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4878           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4879         enddo
4880         endif
4881       enddo
4882       ehpb=0.5D0*ehpb
4883       return
4884       end subroutine edis
4885 !-----------------------------------------------------------------------------
4886       subroutine ssbond_ene(i,j,eij)
4887 !
4888 ! Calculate the distance and angle dependent SS-bond potential energy
4889 ! using a free-energy function derived based on RHF/6-31G** ab initio
4890 ! calculations of diethyl disulfide.
4891 !
4892 ! A. Liwo and U. Kozlowska, 11/24/03
4893 !
4894 !      implicit real*8 (a-h,o-z)
4895 !      include 'DIMENSIONS'
4896 !      include 'COMMON.SBRIDGE'
4897 !      include 'COMMON.CHAIN'
4898 !      include 'COMMON.DERIV'
4899 !      include 'COMMON.LOCAL'
4900 !      include 'COMMON.INTERACT'
4901 !      include 'COMMON.VAR'
4902 !      include 'COMMON.IOUNITS'
4903       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
4904 !el local variables
4905       integer :: i,j,itypi,itypj,k
4906       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
4907                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
4908                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
4909                    cosphi,ggk
4910
4911       itypi=iabs(itype(i))
4912       xi=c(1,nres+i)
4913       yi=c(2,nres+i)
4914       zi=c(3,nres+i)
4915       dxi=dc_norm(1,nres+i)
4916       dyi=dc_norm(2,nres+i)
4917       dzi=dc_norm(3,nres+i)
4918 !      dsci_inv=dsc_inv(itypi)
4919       dsci_inv=vbld_inv(nres+i)
4920       itypj=iabs(itype(j))
4921 !      dscj_inv=dsc_inv(itypj)
4922       dscj_inv=vbld_inv(nres+j)
4923       xj=c(1,nres+j)-xi
4924       yj=c(2,nres+j)-yi
4925       zj=c(3,nres+j)-zi
4926       dxj=dc_norm(1,nres+j)
4927       dyj=dc_norm(2,nres+j)
4928       dzj=dc_norm(3,nres+j)
4929       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4930       rij=dsqrt(rrij)
4931       erij(1)=xj*rij
4932       erij(2)=yj*rij
4933       erij(3)=zj*rij
4934       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4935       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4936       om12=dxi*dxj+dyi*dyj+dzi*dzj
4937       do k=1,3
4938         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4939         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4940       enddo
4941       rij=1.0d0/rij
4942       deltad=rij-d0cm
4943       deltat1=1.0d0-om1
4944       deltat2=1.0d0+om2
4945       deltat12=om2-om1+2.0d0
4946       cosphi=om12-om1*om2
4947       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
4948         +akct*deltad*deltat12 &
4949         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4950 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4951 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4952 !     &  " deltat12",deltat12," eij",eij
4953       ed=2*akcm*deltad+akct*deltat12
4954       pom1=akct*deltad
4955       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4956       eom1=-2*akth*deltat1-pom1-om2*pom2
4957       eom2= 2*akth*deltat2+pom1-om1*pom2
4958       eom12=pom2
4959       do k=1,3
4960         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4961         ghpbx(k,i)=ghpbx(k,i)-ggk &
4962                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
4963                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4964         ghpbx(k,j)=ghpbx(k,j)+ggk &
4965                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
4966                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4967         ghpbc(k,i)=ghpbc(k,i)-ggk
4968         ghpbc(k,j)=ghpbc(k,j)+ggk
4969       enddo
4970 !
4971 ! Calculate the components of the gradient in DC and X
4972 !
4973 !grad      do k=i,j-1
4974 !grad        do l=1,3
4975 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4976 !grad        enddo
4977 !grad      enddo
4978       return
4979       end subroutine ssbond_ene
4980 !-----------------------------------------------------------------------------
4981       subroutine ebond(estr)
4982 !
4983 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4984 !
4985 !      implicit real*8 (a-h,o-z)
4986 !      include 'DIMENSIONS'
4987 !      include 'COMMON.LOCAL'
4988 !      include 'COMMON.GEO'
4989 !      include 'COMMON.INTERACT'
4990 !      include 'COMMON.DERIV'
4991 !      include 'COMMON.VAR'
4992 !      include 'COMMON.CHAIN'
4993 !      include 'COMMON.IOUNITS'
4994 !      include 'COMMON.NAMES'
4995 !      include 'COMMON.FFIELD'
4996 !      include 'COMMON.CONTROL'
4997 !      include 'COMMON.SETUP'
4998       real(kind=8),dimension(3) :: u,ud
4999 !el local variables
5000       integer :: i,j,iti,nbi,k
5001       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5002                    uprod1,uprod2
5003
5004       estr=0.0d0
5005       estr1=0.0d0
5006 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5007 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5008
5009       do i=ibondp_start,ibondp_end
5010         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5011         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5012 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5013 !C          do j=1,3
5014 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5015 !C            *dc(j,i-1)/vbld(i)
5016 !C          enddo
5017 !C          if (energy_dec) write(iout,*) &
5018 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5019         diff = vbld(i)-vbldpDUM
5020         else
5021         diff = vbld(i)-vbldp0
5022         endif
5023         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5024            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5025         estr=estr+diff*diff
5026         do j=1,3
5027           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5028         enddo
5029 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5030 !        endif
5031       enddo
5032       estr=0.5d0*AKP*estr+estr1
5033 !
5034 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5035 !
5036       do i=ibond_start,ibond_end
5037         iti=iabs(itype(i))
5038         if (iti.ne.10 .and. iti.ne.ntyp1) then
5039           nbi=nbondterm(iti)
5040           if (nbi.eq.1) then
5041             diff=vbld(i+nres)-vbldsc0(1,iti)
5042             if (energy_dec) write (iout,*) &
5043             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5044             AKSC(1,iti),AKSC(1,iti)*diff*diff
5045             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5046             do j=1,3
5047               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5048             enddo
5049           else
5050             do j=1,nbi
5051               diff=vbld(i+nres)-vbldsc0(j,iti)
5052               ud(j)=aksc(j,iti)*diff
5053               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5054             enddo
5055             uprod=u(1)
5056             do j=2,nbi
5057               uprod=uprod*u(j)
5058             enddo
5059             usum=0.0d0
5060             usumsqder=0.0d0
5061             do j=1,nbi
5062               uprod1=1.0d0
5063               uprod2=1.0d0
5064               do k=1,nbi
5065                 if (k.ne.j) then
5066                   uprod1=uprod1*u(k)
5067                   uprod2=uprod2*u(k)*u(k)
5068                 endif
5069               enddo
5070               usum=usum+uprod1
5071               usumsqder=usumsqder+ud(j)*uprod2
5072             enddo
5073             estr=estr+uprod/usum
5074             do j=1,3
5075              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5076             enddo
5077           endif
5078         endif
5079       enddo
5080       return
5081       end subroutine ebond
5082 #ifdef CRYST_THETA
5083 !-----------------------------------------------------------------------------
5084       subroutine ebend(etheta)
5085 !
5086 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5087 ! angles gamma and its derivatives in consecutive thetas and gammas.
5088 !
5089       use comm_calcthet
5090 !      implicit real*8 (a-h,o-z)
5091 !      include 'DIMENSIONS'
5092 !      include 'COMMON.LOCAL'
5093 !      include 'COMMON.GEO'
5094 !      include 'COMMON.INTERACT'
5095 !      include 'COMMON.DERIV'
5096 !      include 'COMMON.VAR'
5097 !      include 'COMMON.CHAIN'
5098 !      include 'COMMON.IOUNITS'
5099 !      include 'COMMON.NAMES'
5100 !      include 'COMMON.FFIELD'
5101 !      include 'COMMON.CONTROL'
5102 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5103 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5104 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5105 !el      integer :: it
5106 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5107 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5108 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5109 !el local variables
5110       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5111        ichir21,ichir22
5112       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5113        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5114        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5115       real(kind=8),dimension(2) :: y,z
5116
5117       delta=0.02d0*pi
5118 !      time11=dexp(-2*time)
5119 !      time12=1.0d0
5120       etheta=0.0D0
5121 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5122       do i=ithet_start,ithet_end
5123         if (itype(i-1).eq.ntyp1) cycle
5124 ! Zero the energy function and its derivative at 0 or pi.
5125         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5126         it=itype(i-1)
5127         ichir1=isign(1,itype(i-2))
5128         ichir2=isign(1,itype(i))
5129          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5130          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5131          if (itype(i-1).eq.10) then
5132           itype1=isign(10,itype(i-2))
5133           ichir11=isign(1,itype(i-2))
5134           ichir12=isign(1,itype(i-2))
5135           itype2=isign(10,itype(i))
5136           ichir21=isign(1,itype(i))
5137           ichir22=isign(1,itype(i))
5138          endif
5139
5140         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
5141 #ifdef OSF
5142           phii=phi(i)
5143           if (phii.ne.phii) phii=150.0
5144 #else
5145           phii=phi(i)
5146 #endif
5147           y(1)=dcos(phii)
5148           y(2)=dsin(phii)
5149         else
5150           y(1)=0.0D0
5151           y(2)=0.0D0
5152         endif
5153         if (i.lt.nres .and. itype(i).ne.ntyp1) then
5154 #ifdef OSF
5155           phii1=phi(i+1)
5156           if (phii1.ne.phii1) phii1=150.0
5157           phii1=pinorm(phii1)
5158           z(1)=cos(phii1)
5159 #else
5160           phii1=phi(i+1)
5161           z(1)=dcos(phii1)
5162 #endif
5163           z(2)=dsin(phii1)
5164         else
5165           z(1)=0.0D0
5166           z(2)=0.0D0
5167         endif
5168 ! Calculate the "mean" value of theta from the part of the distribution
5169 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5170 ! In following comments this theta will be referred to as t_c.
5171         thet_pred_mean=0.0d0
5172         do k=1,2
5173             athetk=athet(k,it,ichir1,ichir2)
5174             bthetk=bthet(k,it,ichir1,ichir2)
5175           if (it.eq.10) then
5176              athetk=athet(k,itype1,ichir11,ichir12)
5177              bthetk=bthet(k,itype2,ichir21,ichir22)
5178           endif
5179          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5180         enddo
5181         dthett=thet_pred_mean*ssd
5182         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5183 ! Derivatives of the "mean" values in gamma1 and gamma2.
5184         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5185                +athet(2,it,ichir1,ichir2)*y(1))*ss
5186         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5187                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5188          if (it.eq.10) then
5189         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5190              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5191         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5192                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5193          endif
5194         if (theta(i).gt.pi-delta) then
5195           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5196                E_tc0)
5197           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5198           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5199           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5200               E_theta)
5201           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5202               E_tc)
5203         else if (theta(i).lt.delta) then
5204           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5205           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5206           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5207               E_theta)
5208           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5209           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5210               E_tc)
5211         else
5212           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5213               E_theta,E_tc)
5214         endif
5215         etheta=etheta+ethetai
5216         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5217             'ebend',i,ethetai
5218         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5219         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5220         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5221       enddo
5222 ! Ufff.... We've done all this!!!
5223       return
5224       end subroutine ebend
5225 !-----------------------------------------------------------------------------
5226       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5227
5228       use comm_calcthet
5229 !      implicit real*8 (a-h,o-z)
5230 !      include 'DIMENSIONS'
5231 !      include 'COMMON.LOCAL'
5232 !      include 'COMMON.IOUNITS'
5233 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5234 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5235 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5236       integer :: i,j,k
5237       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5238 !el      integer :: it
5239 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5240 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5241 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5242 !el local variables
5243       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5244        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5245
5246 ! Calculate the contributions to both Gaussian lobes.
5247 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5248 ! The "polynomial part" of the "standard deviation" of this part of
5249 ! the distribution.
5250         sig=polthet(3,it)
5251         do j=2,0,-1
5252           sig=sig*thet_pred_mean+polthet(j,it)
5253         enddo
5254 ! Derivative of the "interior part" of the "standard deviation of the"
5255 ! gamma-dependent Gaussian lobe in t_c.
5256         sigtc=3*polthet(3,it)
5257         do j=2,1,-1
5258           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5259         enddo
5260         sigtc=sig*sigtc
5261 ! Set the parameters of both Gaussian lobes of the distribution.
5262 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5263         fac=sig*sig+sigc0(it)
5264         sigcsq=fac+fac
5265         sigc=1.0D0/sigcsq
5266 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5267         sigsqtc=-4.0D0*sigcsq*sigtc
5268 !       print *,i,sig,sigtc,sigsqtc
5269 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5270         sigtc=-sigtc/(fac*fac)
5271 ! Following variable is sigma(t_c)**(-2)
5272         sigcsq=sigcsq*sigcsq
5273         sig0i=sig0(it)
5274         sig0inv=1.0D0/sig0i**2
5275         delthec=thetai-thet_pred_mean
5276         delthe0=thetai-theta0i
5277         term1=-0.5D0*sigcsq*delthec*delthec
5278         term2=-0.5D0*sig0inv*delthe0*delthe0
5279 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5280 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5281 ! to the energy (this being the log of the distribution) at the end of energy
5282 ! term evaluation for this virtual-bond angle.
5283         if (term1.gt.term2) then
5284           termm=term1
5285           term2=dexp(term2-termm)
5286           term1=1.0d0
5287         else
5288           termm=term2
5289           term1=dexp(term1-termm)
5290           term2=1.0d0
5291         endif
5292 ! The ratio between the gamma-independent and gamma-dependent lobes of
5293 ! the distribution is a Gaussian function of thet_pred_mean too.
5294         diffak=gthet(2,it)-thet_pred_mean
5295         ratak=diffak/gthet(3,it)**2
5296         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5297 ! Let's differentiate it in thet_pred_mean NOW.
5298         aktc=ak*ratak
5299 ! Now put together the distribution terms to make complete distribution.
5300         termexp=term1+ak*term2
5301         termpre=sigc+ak*sig0i
5302 ! Contribution of the bending energy from this theta is just the -log of
5303 ! the sum of the contributions from the two lobes and the pre-exponential
5304 ! factor. Simple enough, isn't it?
5305         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5306 ! NOW the derivatives!!!
5307 ! 6/6/97 Take into account the deformation.
5308         E_theta=(delthec*sigcsq*term1 &
5309              +ak*delthe0*sig0inv*term2)/termexp
5310         E_tc=((sigtc+aktc*sig0i)/termpre &
5311             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5312              aktc*term2)/termexp)
5313       return
5314       end subroutine theteng
5315 #else
5316 !-----------------------------------------------------------------------------
5317       subroutine ebend(etheta)
5318 !
5319 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5320 ! angles gamma and its derivatives in consecutive thetas and gammas.
5321 ! ab initio-derived potentials from
5322 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5323 !
5324 !      implicit real*8 (a-h,o-z)
5325 !      include 'DIMENSIONS'
5326 !      include 'COMMON.LOCAL'
5327 !      include 'COMMON.GEO'
5328 !      include 'COMMON.INTERACT'
5329 !      include 'COMMON.DERIV'
5330 !      include 'COMMON.VAR'
5331 !      include 'COMMON.CHAIN'
5332 !      include 'COMMON.IOUNITS'
5333 !      include 'COMMON.NAMES'
5334 !      include 'COMMON.FFIELD'
5335 !      include 'COMMON.CONTROL'
5336       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5337       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5338       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5339       logical :: lprn=.false., lprn1=.false.
5340 !el local variables
5341       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5342       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5343       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl
5344
5345       etheta=0.0D0
5346       do i=ithet_start,ithet_end
5347         if (itype(i-1).eq.ntyp1) cycle
5348         if (itype(i-2).eq.ntyp1.or.itype(i).eq.ntyp1) cycle
5349         if (iabs(itype(i+1)).eq.20) iblock=2
5350         if (iabs(itype(i+1)).ne.20) iblock=1
5351         dethetai=0.0d0
5352         dephii=0.0d0
5353         dephii1=0.0d0
5354         theti2=0.5d0*theta(i)
5355         ityp2=ithetyp((itype(i-1)))
5356         do k=1,nntheterm
5357           coskt(k)=dcos(k*theti2)
5358           sinkt(k)=dsin(k*theti2)
5359         enddo
5360         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
5361 #ifdef OSF
5362           phii=phi(i)
5363           if (phii.ne.phii) phii=150.0
5364 #else
5365           phii=phi(i)
5366 #endif
5367           ityp1=ithetyp((itype(i-2)))
5368 ! propagation of chirality for glycine type
5369           do k=1,nsingle
5370             cosph1(k)=dcos(k*phii)
5371             sinph1(k)=dsin(k*phii)
5372           enddo
5373         else
5374           phii=0.0d0
5375           ityp1=ithetyp(itype(i-2))
5376           do k=1,nsingle
5377             cosph1(k)=0.0d0
5378             sinph1(k)=0.0d0
5379           enddo
5380         endif
5381         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5382 #ifdef OSF
5383           phii1=phi(i+1)
5384           if (phii1.ne.phii1) phii1=150.0
5385           phii1=pinorm(phii1)
5386 #else
5387           phii1=phi(i+1)
5388 #endif
5389           ityp3=ithetyp((itype(i)))
5390           do k=1,nsingle
5391             cosph2(k)=dcos(k*phii1)
5392             sinph2(k)=dsin(k*phii1)
5393           enddo
5394         else
5395           phii1=0.0d0
5396           ityp3=ithetyp(itype(i))
5397           do k=1,nsingle
5398             cosph2(k)=0.0d0
5399             sinph2(k)=0.0d0
5400           enddo
5401         endif
5402         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5403         do k=1,ndouble
5404           do l=1,k-1
5405             ccl=cosph1(l)*cosph2(k-l)
5406             ssl=sinph1(l)*sinph2(k-l)
5407             scl=sinph1(l)*cosph2(k-l)
5408             csl=cosph1(l)*sinph2(k-l)
5409             cosph1ph2(l,k)=ccl-ssl
5410             cosph1ph2(k,l)=ccl+ssl
5411             sinph1ph2(l,k)=scl+csl
5412             sinph1ph2(k,l)=scl-csl
5413           enddo
5414         enddo
5415         if (lprn) then
5416         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5417           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5418         write (iout,*) "coskt and sinkt"
5419         do k=1,nntheterm
5420           write (iout,*) k,coskt(k),sinkt(k)
5421         enddo
5422         endif
5423         do k=1,ntheterm
5424           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5425           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5426             *coskt(k)
5427           if (lprn) &
5428           write (iout,*) "k",k,&
5429            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5430            " ethetai",ethetai
5431         enddo
5432         if (lprn) then
5433         write (iout,*) "cosph and sinph"
5434         do k=1,nsingle
5435           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5436         enddo
5437         write (iout,*) "cosph1ph2 and sinph2ph2"
5438         do k=2,ndouble
5439           do l=1,k-1
5440             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5441                sinph1ph2(l,k),sinph1ph2(k,l)
5442           enddo
5443         enddo
5444         write(iout,*) "ethetai",ethetai
5445         endif
5446         do m=1,ntheterm2
5447           do k=1,nsingle
5448             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5449                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5450                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5451                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5452             ethetai=ethetai+sinkt(m)*aux
5453             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5454             dephii=dephii+k*sinkt(m)* &
5455                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5456                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5457             dephii1=dephii1+k*sinkt(m)* &
5458                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5459                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5460             if (lprn) &
5461             write (iout,*) "m",m," k",k," bbthet", &
5462                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5463                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5464                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5465                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5466           enddo
5467         enddo
5468         if (lprn) &
5469         write(iout,*) "ethetai",ethetai
5470         do m=1,ntheterm3
5471           do k=2,ndouble
5472             do l=1,k-1
5473               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5474                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5475                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5476                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5477               ethetai=ethetai+sinkt(m)*aux
5478               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5479               dephii=dephii+l*sinkt(m)* &
5480                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5481                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5482                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5483                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5484               dephii1=dephii1+(k-l)*sinkt(m)* &
5485                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5486                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5487                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5488                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5489               if (lprn) then
5490               write (iout,*) "m",m," k",k," l",l," ffthet",&
5491                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5492                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5493                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5494                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5495                   " ethetai",ethetai
5496               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5497                   cosph1ph2(k,l)*sinkt(m),&
5498                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5499               endif
5500             enddo
5501           enddo
5502         enddo
5503 10      continue
5504 !        lprn1=.true.
5505         if (lprn1) &
5506           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5507          i,theta(i)*rad2deg,phii*rad2deg,&
5508          phii1*rad2deg,ethetai
5509 !        lprn1=.false.
5510         etheta=etheta+ethetai
5511         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5512                                     'ebend',i,ethetai
5513         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5514         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5515         gloc(nphi+i-2,icg)=wang*dethetai
5516       enddo
5517       return
5518       end subroutine ebend
5519 #endif
5520 #ifdef CRYST_SC
5521 !-----------------------------------------------------------------------------
5522       subroutine esc(escloc)
5523 ! Calculate the local energy of a side chain and its derivatives in the
5524 ! corresponding virtual-bond valence angles THETA and the spherical angles
5525 ! ALPHA and OMEGA.
5526 !
5527       use comm_sccalc
5528 !      implicit real*8 (a-h,o-z)
5529 !      include 'DIMENSIONS'
5530 !      include 'COMMON.GEO'
5531 !      include 'COMMON.LOCAL'
5532 !      include 'COMMON.VAR'
5533 !      include 'COMMON.INTERACT'
5534 !      include 'COMMON.DERIV'
5535 !      include 'COMMON.CHAIN'
5536 !      include 'COMMON.IOUNITS'
5537 !      include 'COMMON.NAMES'
5538 !      include 'COMMON.FFIELD'
5539 !      include 'COMMON.CONTROL'
5540       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5541          ddersc0,ddummy,xtemp,temp
5542 !el      real(kind=8) :: time11,time12,time112,theti
5543       real(kind=8) :: escloc,delta
5544 !el      integer :: it,nlobit
5545 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5546 !el local variables
5547       integer :: i,k
5548       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5549        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5550       delta=0.02d0*pi
5551       escloc=0.0D0
5552 !     write (iout,'(a)') 'ESC'
5553       do i=loc_start,loc_end
5554         it=itype(i)
5555         if (it.eq.ntyp1) cycle
5556         if (it.eq.10) goto 1
5557         nlobit=nlob(iabs(it))
5558 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5559 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5560         theti=theta(i+1)-pipol
5561         x(1)=dtan(theti)
5562         x(2)=alph(i)
5563         x(3)=omeg(i)
5564
5565         if (x(2).gt.pi-delta) then
5566           xtemp(1)=x(1)
5567           xtemp(2)=pi-delta
5568           xtemp(3)=x(3)
5569           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5570           xtemp(2)=pi
5571           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5572           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5573               escloci,dersc(2))
5574           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5575               ddersc0(1),dersc(1))
5576           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5577               ddersc0(3),dersc(3))
5578           xtemp(2)=pi-delta
5579           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5580           xtemp(2)=pi
5581           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5582           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5583                   dersc0(2),esclocbi,dersc02)
5584           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5585                   dersc12,dersc01)
5586           call splinthet(x(2),0.5d0*delta,ss,ssd)
5587           dersc0(1)=dersc01
5588           dersc0(2)=dersc02
5589           dersc0(3)=0.0d0
5590           do k=1,3
5591             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5592           enddo
5593           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5594 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5595 !    &             esclocbi,ss,ssd
5596           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5597 !         escloci=esclocbi
5598 !         write (iout,*) escloci
5599         else if (x(2).lt.delta) then
5600           xtemp(1)=x(1)
5601           xtemp(2)=delta
5602           xtemp(3)=x(3)
5603           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5604           xtemp(2)=0.0d0
5605           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5606           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
5607               escloci,dersc(2))
5608           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5609               ddersc0(1),dersc(1))
5610           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
5611               ddersc0(3),dersc(3))
5612           xtemp(2)=delta
5613           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5614           xtemp(2)=0.0d0
5615           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5616           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
5617                   dersc0(2),esclocbi,dersc02)
5618           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5619                   dersc12,dersc01)
5620           dersc0(1)=dersc01
5621           dersc0(2)=dersc02
5622           dersc0(3)=0.0d0
5623           call splinthet(x(2),0.5d0*delta,ss,ssd)
5624           do k=1,3
5625             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5626           enddo
5627           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5628 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5629 !    &             esclocbi,ss,ssd
5630           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5631 !         write (iout,*) escloci
5632         else
5633           call enesc(x,escloci,dersc,ddummy,.false.)
5634         endif
5635
5636         escloc=escloc+escloci
5637         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5638            'escloc',i,escloci
5639 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5640
5641         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
5642          wscloc*dersc(1)
5643         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5644         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5645     1   continue
5646       enddo
5647       return
5648       end subroutine esc
5649 !-----------------------------------------------------------------------------
5650       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5651
5652       use comm_sccalc
5653 !      implicit real*8 (a-h,o-z)
5654 !      include 'DIMENSIONS'
5655 !      include 'COMMON.GEO'
5656 !      include 'COMMON.LOCAL'
5657 !      include 'COMMON.IOUNITS'
5658 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5659       real(kind=8),dimension(3) :: x,z,dersc,ddersc
5660       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
5661       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
5662       real(kind=8) :: escloci
5663       logical :: mixed
5664 !el local variables
5665       integer :: j,iii,l,k !el,it,nlobit
5666       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
5667 !el       time11,time12,time112
5668 !       write (iout,*) 'it=',it,' nlobit=',nlobit
5669         escloc_i=0.0D0
5670         do j=1,3
5671           dersc(j)=0.0D0
5672           if (mixed) ddersc(j)=0.0d0
5673         enddo
5674         x3=x(3)
5675
5676 ! Because of periodicity of the dependence of the SC energy in omega we have
5677 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5678 ! To avoid underflows, first compute & store the exponents.
5679
5680         do iii=-1,1
5681
5682           x(3)=x3+iii*dwapi
5683
5684           do j=1,nlobit
5685             do k=1,3
5686               z(k)=x(k)-censc(k,j,it)
5687             enddo
5688             do k=1,3
5689               Axk=0.0D0
5690               do l=1,3
5691                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5692               enddo
5693               Ax(k,j,iii)=Axk
5694             enddo
5695             expfac=0.0D0
5696             do k=1,3
5697               expfac=expfac+Ax(k,j,iii)*z(k)
5698             enddo
5699             contr(j,iii)=expfac
5700           enddo ! j
5701
5702         enddo ! iii
5703
5704         x(3)=x3
5705 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5706 ! subsequent NaNs and INFs in energy calculation.
5707 ! Find the largest exponent
5708         emin=contr(1,-1)
5709         do iii=-1,1
5710           do j=1,nlobit
5711             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5712           enddo
5713         enddo
5714         emin=0.5D0*emin
5715 !d      print *,'it=',it,' emin=',emin
5716
5717 ! Compute the contribution to SC energy and derivatives
5718         do iii=-1,1
5719
5720           do j=1,nlobit
5721 #ifdef OSF
5722             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5723             if(adexp.ne.adexp) adexp=1.0
5724             expfac=dexp(adexp)
5725 #else
5726             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5727 #endif
5728 !d          print *,'j=',j,' expfac=',expfac
5729             escloc_i=escloc_i+expfac
5730             do k=1,3
5731               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5732             enddo
5733             if (mixed) then
5734               do k=1,3,2
5735                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
5736                   +gaussc(k,2,j,it))*expfac
5737               enddo
5738             endif
5739           enddo
5740
5741         enddo ! iii
5742
5743         dersc(1)=dersc(1)/cos(theti)**2
5744         ddersc(1)=ddersc(1)/cos(theti)**2
5745         ddersc(3)=ddersc(3)
5746
5747         escloci=-(dlog(escloc_i)-emin)
5748         do j=1,3
5749           dersc(j)=dersc(j)/escloc_i
5750         enddo
5751         if (mixed) then
5752           do j=1,3,2
5753             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5754           enddo
5755         endif
5756       return
5757       end subroutine enesc
5758 !-----------------------------------------------------------------------------
5759       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5760
5761       use comm_sccalc
5762 !      implicit real*8 (a-h,o-z)
5763 !      include 'DIMENSIONS'
5764 !      include 'COMMON.GEO'
5765 !      include 'COMMON.LOCAL'
5766 !      include 'COMMON.IOUNITS'
5767 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5768       real(kind=8),dimension(3) :: x,z,dersc
5769       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
5770       real(kind=8),dimension(nlobit) :: contr !(maxlob)
5771       real(kind=8) :: escloci,dersc12,emin
5772       logical :: mixed
5773 !el local varables
5774       integer :: j,k,l !el,it,nlobit
5775       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
5776
5777       escloc_i=0.0D0
5778
5779       do j=1,3
5780         dersc(j)=0.0D0
5781       enddo
5782
5783       do j=1,nlobit
5784         do k=1,2
5785           z(k)=x(k)-censc(k,j,it)
5786         enddo
5787         z(3)=dwapi
5788         do k=1,3
5789           Axk=0.0D0
5790           do l=1,3
5791             Axk=Axk+gaussc(l,k,j,it)*z(l)
5792           enddo
5793           Ax(k,j)=Axk
5794         enddo
5795         expfac=0.0D0
5796         do k=1,3
5797           expfac=expfac+Ax(k,j)*z(k)
5798         enddo
5799         contr(j)=expfac
5800       enddo ! j
5801
5802 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5803 ! subsequent NaNs and INFs in energy calculation.
5804 ! Find the largest exponent
5805       emin=contr(1)
5806       do j=1,nlobit
5807         if (emin.gt.contr(j)) emin=contr(j)
5808       enddo
5809       emin=0.5D0*emin
5810
5811 ! Compute the contribution to SC energy and derivatives
5812
5813       dersc12=0.0d0
5814       do j=1,nlobit
5815         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5816         escloc_i=escloc_i+expfac
5817         do k=1,2
5818           dersc(k)=dersc(k)+Ax(k,j)*expfac
5819         enddo
5820         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
5821                   +gaussc(1,2,j,it))*expfac
5822         dersc(3)=0.0d0
5823       enddo
5824
5825       dersc(1)=dersc(1)/cos(theti)**2
5826       dersc12=dersc12/cos(theti)**2
5827       escloci=-(dlog(escloc_i)-emin)
5828       do j=1,2
5829         dersc(j)=dersc(j)/escloc_i
5830       enddo
5831       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5832       return
5833       end subroutine enesc_bound
5834 #else
5835 !-----------------------------------------------------------------------------
5836       subroutine esc(escloc)
5837 ! Calculate the local energy of a side chain and its derivatives in the
5838 ! corresponding virtual-bond valence angles THETA and the spherical angles
5839 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
5840 ! added by Urszula Kozlowska. 07/11/2007
5841 !
5842       use comm_sccalc
5843 !      implicit real*8 (a-h,o-z)
5844 !      include 'DIMENSIONS'
5845 !      include 'COMMON.GEO'
5846 !      include 'COMMON.LOCAL'
5847 !      include 'COMMON.VAR'
5848 !      include 'COMMON.SCROT'
5849 !      include 'COMMON.INTERACT'
5850 !      include 'COMMON.DERIV'
5851 !      include 'COMMON.CHAIN'
5852 !      include 'COMMON.IOUNITS'
5853 !      include 'COMMON.NAMES'
5854 !      include 'COMMON.FFIELD'
5855 !      include 'COMMON.CONTROL'
5856 !      include 'COMMON.VECTORS'
5857       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
5858       real(kind=8),dimension(65) :: x
5859       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
5860          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
5861       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
5862       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
5863          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
5864 !el local variables
5865       integer :: i,j,k !el,it,nlobit
5866       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
5867 !el      real(kind=8) :: time11,time12,time112,theti
5868 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5869       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
5870                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
5871                    sumene1x,sumene2x,sumene3x,sumene4x,&
5872                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
5873                    cosfac2xx,sinfac2yy
5874 #ifdef DEBUG
5875       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
5876                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
5877                    de_dt_num
5878 #endif
5879 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
5880
5881       delta=0.02d0*pi
5882       escloc=0.0D0
5883       do i=loc_start,loc_end
5884         if (itype(i).eq.ntyp1) cycle
5885         costtab(i+1) =dcos(theta(i+1))
5886         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5887         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5888         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5889         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5890         cosfac=dsqrt(cosfac2)
5891         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5892         sinfac=dsqrt(sinfac2)
5893         it=iabs(itype(i))
5894         if (it.eq.10) goto 1
5895 !
5896 !  Compute the axes of tghe local cartesian coordinates system; store in
5897 !   x_prime, y_prime and z_prime
5898 !
5899         do j=1,3
5900           x_prime(j) = 0.00
5901           y_prime(j) = 0.00
5902           z_prime(j) = 0.00
5903         enddo
5904 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5905 !     &   dc_norm(3,i+nres)
5906         do j = 1,3
5907           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5908           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5909         enddo
5910         do j = 1,3
5911           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5912         enddo
5913 !       write (2,*) "i",i
5914 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
5915 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
5916 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
5917 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5918 !      & " xy",scalar(x_prime(1),y_prime(1)),
5919 !      & " xz",scalar(x_prime(1),z_prime(1)),
5920 !      & " yy",scalar(y_prime(1),y_prime(1)),
5921 !      & " yz",scalar(y_prime(1),z_prime(1)),
5922 !      & " zz",scalar(z_prime(1),z_prime(1))
5923 !
5924 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5925 ! to local coordinate system. Store in xx, yy, zz.
5926 !
5927         xx=0.0d0
5928         yy=0.0d0
5929         zz=0.0d0
5930         do j = 1,3
5931           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5932           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5933           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5934         enddo
5935
5936         xxtab(i)=xx
5937         yytab(i)=yy
5938         zztab(i)=zz
5939 !
5940 ! Compute the energy of the ith side cbain
5941 !
5942 !        write (2,*) "xx",xx," yy",yy," zz",zz
5943         it=iabs(itype(i))
5944         do j = 1,65
5945           x(j) = sc_parmin(j,it)
5946         enddo
5947 #ifdef CHECK_COORD
5948 !c diagnostics - remove later
5949         xx1 = dcos(alph(2))
5950         yy1 = dsin(alph(2))*dcos(omeg(2))
5951         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5952         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
5953           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
5954           xx1,yy1,zz1
5955 !,"  --- ", xx_w,yy_w,zz_w
5956 ! end diagnostics
5957 #endif
5958         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5959          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5960          + x(10)*yy*zz
5961         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5962          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5963          + x(20)*yy*zz
5964         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5965          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5966          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5967          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5968          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5969          +x(40)*xx*yy*zz
5970         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5971          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5972          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5973          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5974          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5975          +x(60)*xx*yy*zz
5976         dsc_i   = 0.743d0+x(61)
5977         dp2_i   = 1.9d0+x(62)
5978         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5979                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5980         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5981                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5982         s1=(1+x(63))/(0.1d0 + dscp1)
5983         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5984         s2=(1+x(65))/(0.1d0 + dscp2)
5985         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5986         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
5987       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5988 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5989 !     &   sumene4,
5990 !     &   dscp1,dscp2,sumene
5991 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5992         escloc = escloc + sumene
5993 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5994 !     & ,zz,xx,yy
5995 !#define DEBUG
5996 #ifdef DEBUG
5997 !
5998 ! This section to check the numerical derivatives of the energy of ith side
5999 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6000 ! #define DEBUG in the code to turn it on.
6001 !
6002         write (2,*) "sumene               =",sumene
6003         aincr=1.0d-7
6004         xxsave=xx
6005         xx=xx+aincr
6006         write (2,*) xx,yy,zz
6007         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6008         de_dxx_num=(sumenep-sumene)/aincr
6009         xx=xxsave
6010         write (2,*) "xx+ sumene from enesc=",sumenep
6011         yysave=yy
6012         yy=yy+aincr
6013         write (2,*) xx,yy,zz
6014         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6015         de_dyy_num=(sumenep-sumene)/aincr
6016         yy=yysave
6017         write (2,*) "yy+ sumene from enesc=",sumenep
6018         zzsave=zz
6019         zz=zz+aincr
6020         write (2,*) xx,yy,zz
6021         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6022         de_dzz_num=(sumenep-sumene)/aincr
6023         zz=zzsave
6024         write (2,*) "zz+ sumene from enesc=",sumenep
6025         costsave=cost2tab(i+1)
6026         sintsave=sint2tab(i+1)
6027         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6028         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6029         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6030         de_dt_num=(sumenep-sumene)/aincr
6031         write (2,*) " t+ sumene from enesc=",sumenep
6032         cost2tab(i+1)=costsave
6033         sint2tab(i+1)=sintsave
6034 ! End of diagnostics section.
6035 #endif
6036 !
6037 ! Compute the gradient of esc
6038 !
6039 !        zz=zz*dsign(1.0,dfloat(itype(i)))
6040         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6041         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6042         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6043         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6044         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6045         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6046         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6047         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6048         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6049            *(pom_s1/dscp1+pom_s16*dscp1**4)
6050         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6051            *(pom_s2/dscp2+pom_s26*dscp2**4)
6052         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6053         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6054         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6055         +x(40)*yy*zz
6056         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6057         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6058         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6059         +x(60)*yy*zz
6060         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6061               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6062               +(pom1+pom2)*pom_dx
6063 #ifdef DEBUG
6064         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6065 #endif
6066 !
6067         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6068         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6069         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6070         +x(40)*xx*zz
6071         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6072         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6073         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6074         +x(59)*zz**2 +x(60)*xx*zz
6075         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6076               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6077               +(pom1-pom2)*pom_dy
6078 #ifdef DEBUG
6079         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6080 #endif
6081 !
6082         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6083         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6084         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6085         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6086         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6087         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6088         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6089         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6090 #ifdef DEBUG
6091         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6092 #endif
6093 !
6094         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6095         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6096         +pom1*pom_dt1+pom2*pom_dt2
6097 #ifdef DEBUG
6098         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6099 #endif
6100 !
6101 !
6102        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6103        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6104        cosfac2xx=cosfac2*xx
6105        sinfac2yy=sinfac2*yy
6106        do k = 1,3
6107          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6108             vbld_inv(i+1)
6109          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6110             vbld_inv(i)
6111          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6112          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6113 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6114 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6115 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6116 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6117          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6118          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6119          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6120          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6121          dZZ_Ci1(k)=0.0d0
6122          dZZ_Ci(k)=0.0d0
6123          do j=1,3
6124            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6125            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6126            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6127            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6128          enddo
6129
6130          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6131          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6132          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6133          (z_prime(k)-zz*dC_norm(k,i+nres))
6134 !
6135          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6136          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6137        enddo
6138
6139        do k=1,3
6140          dXX_Ctab(k,i)=dXX_Ci(k)
6141          dXX_C1tab(k,i)=dXX_Ci1(k)
6142          dYY_Ctab(k,i)=dYY_Ci(k)
6143          dYY_C1tab(k,i)=dYY_Ci1(k)
6144          dZZ_Ctab(k,i)=dZZ_Ci(k)
6145          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6146          dXX_XYZtab(k,i)=dXX_XYZ(k)
6147          dYY_XYZtab(k,i)=dYY_XYZ(k)
6148          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6149        enddo
6150
6151        do k = 1,3
6152 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6153 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6154 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6155 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6156 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6157 !     &    dt_dci(k)
6158 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6159 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6160          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6161           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6162          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6163           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6164          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6165           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6166        enddo
6167 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6168 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6169
6170 ! to check gradient call subroutine check_grad
6171
6172     1 continue
6173       enddo
6174       return
6175       end subroutine esc
6176 !-----------------------------------------------------------------------------
6177       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6178 !      implicit none
6179       real(kind=8),dimension(65) :: x
6180       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6181         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6182
6183       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6184         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6185         + x(10)*yy*zz
6186       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6187         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6188         + x(20)*yy*zz
6189       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6190         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6191         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6192         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6193         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6194         +x(40)*xx*yy*zz
6195       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6196         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6197         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6198         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6199         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6200         +x(60)*xx*yy*zz
6201       dsc_i   = 0.743d0+x(61)
6202       dp2_i   = 1.9d0+x(62)
6203       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6204                 *(xx*cost2+yy*sint2))
6205       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6206                 *(xx*cost2-yy*sint2))
6207       s1=(1+x(63))/(0.1d0 + dscp1)
6208       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6209       s2=(1+x(65))/(0.1d0 + dscp2)
6210       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6211       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6212        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6213       enesc=sumene
6214       return
6215       end function enesc
6216 #endif
6217 !-----------------------------------------------------------------------------
6218       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6219 !
6220 ! This procedure calculates two-body contact function g(rij) and its derivative:
6221 !
6222 !           eps0ij                                     !       x < -1
6223 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6224 !            0                                         !       x > 1
6225 !
6226 ! where x=(rij-r0ij)/delta
6227 !
6228 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6229 !
6230 !      implicit none
6231       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6232       real(kind=8) :: x,x2,x4,delta
6233 !     delta=0.02D0*r0ij
6234 !      delta=0.2D0*r0ij
6235       x=(rij-r0ij)/delta
6236       if (x.lt.-1.0D0) then
6237         fcont=eps0ij
6238         fprimcont=0.0D0
6239       else if (x.le.1.0D0) then
6240         x2=x*x
6241         x4=x2*x2
6242         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6243         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6244       else
6245         fcont=0.0D0
6246         fprimcont=0.0D0
6247       endif
6248       return
6249       end subroutine gcont
6250 !-----------------------------------------------------------------------------
6251       subroutine splinthet(theti,delta,ss,ssder)
6252 !      implicit real*8 (a-h,o-z)
6253 !      include 'DIMENSIONS'
6254 !      include 'COMMON.VAR'
6255 !      include 'COMMON.GEO'
6256       real(kind=8) :: theti,delta,ss,ssder
6257       real(kind=8) :: thetup,thetlow
6258       thetup=pi-delta
6259       thetlow=delta
6260       if (theti.gt.pipol) then
6261         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6262       else
6263         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6264         ssder=-ssder
6265       endif
6266       return
6267       end subroutine splinthet
6268 !-----------------------------------------------------------------------------
6269       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6270 !      implicit none
6271       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6272       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6273       a1=fprim0*delta/(f1-f0)
6274       a2=3.0d0-2.0d0*a1
6275       a3=a1-2.0d0
6276       ksi=(x-x0)/delta
6277       ksi2=ksi*ksi
6278       ksi3=ksi2*ksi
6279       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6280       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6281       return
6282       end subroutine spline1
6283 !-----------------------------------------------------------------------------
6284       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6285 !      implicit none
6286       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6287       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6288       ksi=(x-x0)/delta
6289       ksi2=ksi*ksi
6290       ksi3=ksi2*ksi
6291       a1=fprim0x*delta
6292       a2=3*(f1x-f0x)-2*fprim0x*delta
6293       a3=fprim0x*delta-2*(f1x-f0x)
6294       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6295       return
6296       end subroutine spline2
6297 !-----------------------------------------------------------------------------
6298 #ifdef CRYST_TOR
6299 !-----------------------------------------------------------------------------
6300       subroutine etor(etors,edihcnstr)
6301 !      implicit real*8 (a-h,o-z)
6302 !      include 'DIMENSIONS'
6303 !      include 'COMMON.VAR'
6304 !      include 'COMMON.GEO'
6305 !      include 'COMMON.LOCAL'
6306 !      include 'COMMON.TORSION'
6307 !      include 'COMMON.INTERACT'
6308 !      include 'COMMON.DERIV'
6309 !      include 'COMMON.CHAIN'
6310 !      include 'COMMON.NAMES'
6311 !      include 'COMMON.IOUNITS'
6312 !      include 'COMMON.FFIELD'
6313 !      include 'COMMON.TORCNSTR'
6314 !      include 'COMMON.CONTROL'
6315       real(kind=8) :: etors,edihcnstr
6316       logical :: lprn
6317 !el local variables
6318       integer :: i,j,
6319       real(kind=8) :: phii,fac,etors_ii
6320
6321 ! Set lprn=.true. for debugging
6322       lprn=.false.
6323 !      lprn=.true.
6324       etors=0.0D0
6325       do i=iphi_start,iphi_end
6326       etors_ii=0.0D0
6327         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 &
6328             .or. itype(i).eq.ntyp1) cycle
6329         itori=itortyp(itype(i-2))
6330         itori1=itortyp(itype(i-1))
6331         phii=phi(i)
6332         gloci=0.0D0
6333 ! Proline-Proline pair is a special case...
6334         if (itori.eq.3 .and. itori1.eq.3) then
6335           if (phii.gt.-dwapi3) then
6336             cosphi=dcos(3*phii)
6337             fac=1.0D0/(1.0D0-cosphi)
6338             etorsi=v1(1,3,3)*fac
6339             etorsi=etorsi+etorsi
6340             etors=etors+etorsi-v1(1,3,3)
6341             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6342             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6343           endif
6344           do j=1,3
6345             v1ij=v1(j+1,itori,itori1)
6346             v2ij=v2(j+1,itori,itori1)
6347             cosphi=dcos(j*phii)
6348             sinphi=dsin(j*phii)
6349             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6350             if (energy_dec) etors_ii=etors_ii+ &
6351                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6352             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6353           enddo
6354         else
6355           do j=1,nterm_old
6356             v1ij=v1(j,itori,itori1)
6357             v2ij=v2(j,itori,itori1)
6358             cosphi=dcos(j*phii)
6359             sinphi=dsin(j*phii)
6360             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6361             if (energy_dec) etors_ii=etors_ii+ &
6362                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6363             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6364           enddo
6365         endif
6366         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6367              'etor',i,etors_ii
6368         if (lprn) &
6369         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6370         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
6371         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6372         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6373 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6374       enddo
6375 ! 6/20/98 - dihedral angle constraints
6376       edihcnstr=0.0d0
6377       do i=1,ndih_constr
6378         itori=idih_constr(i)
6379         phii=phi(itori)
6380         difi=phii-phi0(i)
6381         if (difi.gt.drange(i)) then
6382           difi=difi-drange(i)
6383           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6384           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6385         else if (difi.lt.-drange(i)) then
6386           difi=difi+drange(i)
6387           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6388           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6389         endif
6390 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6391 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6392       enddo
6393 !      write (iout,*) 'edihcnstr',edihcnstr
6394       return
6395       end subroutine etor
6396 !-----------------------------------------------------------------------------
6397       subroutine etor_d(etors_d)
6398       real(kind=8) :: etors_d
6399       etors_d=0.0d0
6400       return
6401       end subroutine etor_d
6402 #else
6403 !-----------------------------------------------------------------------------
6404       subroutine etor(etors,edihcnstr)
6405 !      implicit real*8 (a-h,o-z)
6406 !      include 'DIMENSIONS'
6407 !      include 'COMMON.VAR'
6408 !      include 'COMMON.GEO'
6409 !      include 'COMMON.LOCAL'
6410 !      include 'COMMON.TORSION'
6411 !      include 'COMMON.INTERACT'
6412 !      include 'COMMON.DERIV'
6413 !      include 'COMMON.CHAIN'
6414 !      include 'COMMON.NAMES'
6415 !      include 'COMMON.IOUNITS'
6416 !      include 'COMMON.FFIELD'
6417 !      include 'COMMON.TORCNSTR'
6418 !      include 'COMMON.CONTROL'
6419       real(kind=8) :: etors,edihcnstr
6420       logical :: lprn
6421 !el local variables
6422       integer :: i,j,iblock,itori,itori1
6423       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6424                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6425 ! Set lprn=.true. for debugging
6426       lprn=.false.
6427 !     lprn=.true.
6428       etors=0.0D0
6429       do i=iphi_start,iphi_end
6430         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
6431              .or. itype(i-3).eq.ntyp1 &
6432              .or. itype(i).eq.ntyp1) cycle
6433         etors_ii=0.0D0
6434          if (iabs(itype(i)).eq.20) then
6435          iblock=2
6436          else
6437          iblock=1
6438          endif
6439         itori=itortyp(itype(i-2))
6440         itori1=itortyp(itype(i-1))
6441         phii=phi(i)
6442         gloci=0.0D0
6443 ! Regular cosine and sine terms
6444         do j=1,nterm(itori,itori1,iblock)
6445           v1ij=v1(j,itori,itori1,iblock)
6446           v2ij=v2(j,itori,itori1,iblock)
6447           cosphi=dcos(j*phii)
6448           sinphi=dsin(j*phii)
6449           etors=etors+v1ij*cosphi+v2ij*sinphi
6450           if (energy_dec) etors_ii=etors_ii+ &
6451                      v1ij*cosphi+v2ij*sinphi
6452           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6453         enddo
6454 ! Lorentz terms
6455 !                         v1
6456 !  E = SUM ----------------------------------- - v1
6457 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6458 !
6459         cosphi=dcos(0.5d0*phii)
6460         sinphi=dsin(0.5d0*phii)
6461         do j=1,nlor(itori,itori1,iblock)
6462           vl1ij=vlor1(j,itori,itori1)
6463           vl2ij=vlor2(j,itori,itori1)
6464           vl3ij=vlor3(j,itori,itori1)
6465           pom=vl2ij*cosphi+vl3ij*sinphi
6466           pom1=1.0d0/(pom*pom+1.0d0)
6467           etors=etors+vl1ij*pom1
6468           if (energy_dec) etors_ii=etors_ii+ &
6469                      vl1ij*pom1
6470           pom=-pom*pom1*pom1
6471           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6472         enddo
6473 ! Subtract the constant term
6474         etors=etors-v0(itori,itori1,iblock)
6475           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6476                'etor',i,etors_ii-v0(itori,itori1,iblock)
6477         if (lprn) &
6478         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6479         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
6480         (v1(j,itori,itori1,iblock),j=1,6),&
6481         (v2(j,itori,itori1,iblock),j=1,6)
6482         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6483 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6484       enddo
6485 ! 6/20/98 - dihedral angle constraints
6486       edihcnstr=0.0d0
6487 !      do i=1,ndih_constr
6488       do i=idihconstr_start,idihconstr_end
6489         itori=idih_constr(i)
6490         phii=phi(itori)
6491         difi=pinorm(phii-phi0(i))
6492         if (difi.gt.drange(i)) then
6493           difi=difi-drange(i)
6494           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6495           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6496         else if (difi.lt.-drange(i)) then
6497           difi=difi+drange(i)
6498           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6499           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6500         else
6501           difi=0.0
6502         endif
6503 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6504 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6505 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6506       enddo
6507 !d       write (iout,*) 'edihcnstr',edihcnstr
6508       return
6509       end subroutine etor
6510 !-----------------------------------------------------------------------------
6511       subroutine etor_d(etors_d)
6512 ! 6/23/01 Compute double torsional energy
6513 !      implicit real*8 (a-h,o-z)
6514 !      include 'DIMENSIONS'
6515 !      include 'COMMON.VAR'
6516 !      include 'COMMON.GEO'
6517 !      include 'COMMON.LOCAL'
6518 !      include 'COMMON.TORSION'
6519 !      include 'COMMON.INTERACT'
6520 !      include 'COMMON.DERIV'
6521 !      include 'COMMON.CHAIN'
6522 !      include 'COMMON.NAMES'
6523 !      include 'COMMON.IOUNITS'
6524 !      include 'COMMON.FFIELD'
6525 !      include 'COMMON.TORCNSTR'
6526       real(kind=8) :: etors_d,etors_d_ii
6527       logical :: lprn
6528 !el local variables
6529       integer :: i,j,k,l,itori,itori1,itori2,iblock
6530       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6531                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6532                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6533                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6534 ! Set lprn=.true. for debugging
6535       lprn=.false.
6536 !     lprn=.true.
6537       etors_d=0.0D0
6538 !      write(iout,*) "a tu??"
6539       do i=iphid_start,iphid_end
6540         etors_d_ii=0.0D0
6541         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
6542             .or. itype(i-3).eq.ntyp1 &
6543             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
6544         itori=itortyp(itype(i-2))
6545         itori1=itortyp(itype(i-1))
6546         itori2=itortyp(itype(i))
6547         phii=phi(i)
6548         phii1=phi(i+1)
6549         gloci1=0.0D0
6550         gloci2=0.0D0
6551         iblock=1
6552         if (iabs(itype(i+1)).eq.20) iblock=2
6553
6554 ! Regular cosine and sine terms
6555         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6556           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6557           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6558           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6559           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6560           cosphi1=dcos(j*phii)
6561           sinphi1=dsin(j*phii)
6562           cosphi2=dcos(j*phii1)
6563           sinphi2=dsin(j*phii1)
6564           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6565            v2cij*cosphi2+v2sij*sinphi2
6566           if (energy_dec) etors_d_ii=etors_d_ii+ &
6567            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6568           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6569           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6570         enddo
6571         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6572           do l=1,k-1
6573             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6574             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6575             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6576             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6577             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6578             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6579             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6580             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6581             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6582               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6583             if (energy_dec) etors_d_ii=etors_d_ii+ &
6584               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6585               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6586             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6587               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6588             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6589               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6590           enddo
6591         enddo
6592         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6593                             'etor_d',i,etors_d_ii
6594         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6595         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6596       enddo
6597       return
6598       end subroutine etor_d
6599 #endif
6600 !-----------------------------------------------------------------------------
6601       subroutine eback_sc_corr(esccor)
6602 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
6603 !        conformational states; temporarily implemented as differences
6604 !        between UNRES torsional potentials (dependent on three types of
6605 !        residues) and the torsional potentials dependent on all 20 types
6606 !        of residues computed from AM1  energy surfaces of terminally-blocked
6607 !        amino-acid residues.
6608 !      implicit real*8 (a-h,o-z)
6609 !      include 'DIMENSIONS'
6610 !      include 'COMMON.VAR'
6611 !      include 'COMMON.GEO'
6612 !      include 'COMMON.LOCAL'
6613 !      include 'COMMON.TORSION'
6614 !      include 'COMMON.SCCOR'
6615 !      include 'COMMON.INTERACT'
6616 !      include 'COMMON.DERIV'
6617 !      include 'COMMON.CHAIN'
6618 !      include 'COMMON.NAMES'
6619 !      include 'COMMON.IOUNITS'
6620 !      include 'COMMON.FFIELD'
6621 !      include 'COMMON.CONTROL'
6622       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
6623                    cosphi,sinphi
6624       logical :: lprn
6625       integer :: i,interty,j,isccori,isccori1,intertyp
6626 ! Set lprn=.true. for debugging
6627       lprn=.false.
6628 !      lprn=.true.
6629 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6630       esccor=0.0D0
6631       do i=itau_start,itau_end
6632         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6633         esccor_ii=0.0D0
6634         isccori=isccortyp(itype(i-2))
6635         isccori1=isccortyp(itype(i-1))
6636
6637 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6638         phii=phi(i)
6639         do intertyp=1,3 !intertyp
6640          esccor_ii=0.0D0
6641 !c Added 09 May 2012 (Adasko)
6642 !c  Intertyp means interaction type of backbone mainchain correlation:
6643 !   1 = SC...Ca...Ca...Ca
6644 !   2 = Ca...Ca...Ca...SC
6645 !   3 = SC...Ca...Ca...SCi
6646         gloci=0.0D0
6647         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
6648             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
6649             (itype(i-1).eq.ntyp1))) &
6650           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
6651            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
6652            .or.(itype(i).eq.ntyp1))) &
6653           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
6654             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
6655             (itype(i-3).eq.ntyp1)))) cycle
6656         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6657         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
6658        cycle
6659        do j=1,nterm_sccor(isccori,isccori1)
6660           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6661           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6662           cosphi=dcos(j*tauangle(intertyp,i))
6663           sinphi=dsin(j*tauangle(intertyp,i))
6664           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6665           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6666           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6667         enddo
6668         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
6669                                 'esccor',i,intertyp,esccor_ii
6670 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6671         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6672         if (lprn) &
6673         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6674         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
6675         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
6676         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6677         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6678        enddo !intertyp
6679       enddo
6680
6681       return
6682       end subroutine eback_sc_corr
6683 !-----------------------------------------------------------------------------
6684       subroutine multibody(ecorr)
6685 ! This subroutine calculates multi-body contributions to energy following
6686 ! the idea of Skolnick et al. If side chains I and J make a contact and
6687 ! at the same time side chains I+1 and J+1 make a contact, an extra
6688 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6689 !      implicit real*8 (a-h,o-z)
6690 !      include 'DIMENSIONS'
6691 !      include 'COMMON.IOUNITS'
6692 !      include 'COMMON.DERIV'
6693 !      include 'COMMON.INTERACT'
6694 !      include 'COMMON.CONTACTS'
6695       real(kind=8),dimension(3) :: gx,gx1
6696       logical :: lprn
6697       real(kind=8) :: ecorr
6698       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
6699 ! Set lprn=.true. for debugging
6700       lprn=.false.
6701
6702       if (lprn) then
6703         write (iout,'(a)') 'Contact function values:'
6704         do i=nnt,nct-2
6705           write (iout,'(i2,20(1x,i2,f10.5))') &
6706               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6707         enddo
6708       endif
6709       ecorr=0.0D0
6710
6711 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6712 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6713       do i=nnt,nct
6714         do j=1,3
6715           gradcorr(j,i)=0.0D0
6716           gradxorr(j,i)=0.0D0
6717         enddo
6718       enddo
6719       do i=nnt,nct-2
6720
6721         DO ISHIFT = 3,4
6722
6723         i1=i+ishift
6724         num_conti=num_cont(i)
6725         num_conti1=num_cont(i1)
6726         do jj=1,num_conti
6727           j=jcont(jj,i)
6728           do kk=1,num_conti1
6729             j1=jcont(kk,i1)
6730             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6731 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6732 !d   &                   ' ishift=',ishift
6733 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6734 ! The system gains extra energy.
6735               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6736             endif   ! j1==j+-ishift
6737           enddo     ! kk
6738         enddo       ! jj
6739
6740         ENDDO ! ISHIFT
6741
6742       enddo         ! i
6743       return
6744       end subroutine multibody
6745 !-----------------------------------------------------------------------------
6746       real(kind=8) function esccorr(i,j,k,l,jj,kk)
6747 !      implicit real*8 (a-h,o-z)
6748 !      include 'DIMENSIONS'
6749 !      include 'COMMON.IOUNITS'
6750 !      include 'COMMON.DERIV'
6751 !      include 'COMMON.INTERACT'
6752 !      include 'COMMON.CONTACTS'
6753       real(kind=8),dimension(3) :: gx,gx1
6754       logical :: lprn
6755       integer :: i,j,k,l,jj,kk,m,ll
6756       real(kind=8) :: eij,ekl
6757       lprn=.false.
6758       eij=facont(jj,i)
6759       ekl=facont(kk,k)
6760 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6761 ! Calculate the multi-body contribution to energy.
6762 ! Calculate multi-body contributions to the gradient.
6763 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6764 !d   & k,l,(gacont(m,kk,k),m=1,3)
6765       do m=1,3
6766         gx(m) =ekl*gacont(m,jj,i)
6767         gx1(m)=eij*gacont(m,kk,k)
6768         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6769         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6770         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6771         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6772       enddo
6773       do m=i,j-1
6774         do ll=1,3
6775           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6776         enddo
6777       enddo
6778       do m=k,l-1
6779         do ll=1,3
6780           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6781         enddo
6782       enddo
6783       esccorr=-eij*ekl
6784       return
6785       end function esccorr
6786 !-----------------------------------------------------------------------------
6787       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6788 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6789 !      implicit real*8 (a-h,o-z)
6790 !      include 'DIMENSIONS'
6791 !      include 'COMMON.IOUNITS'
6792 #ifdef MPI
6793       include "mpif.h"
6794 !      integer :: maxconts !max_cont=maxconts  =nres/4
6795       integer,parameter :: max_dim=26
6796       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6797       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6798 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6799 !el      common /przechowalnia/ zapas
6800       integer :: status(MPI_STATUS_SIZE)
6801       integer,dimension((nres/4)*2) :: req !maxconts*2
6802       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
6803 #endif
6804 !      include 'COMMON.SETUP'
6805 !      include 'COMMON.FFIELD'
6806 !      include 'COMMON.DERIV'
6807 !      include 'COMMON.INTERACT'
6808 !      include 'COMMON.CONTACTS'
6809 !      include 'COMMON.CONTROL'
6810 !      include 'COMMON.LOCAL'
6811       real(kind=8),dimension(3) :: gx,gx1
6812       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
6813       logical :: lprn,ldone
6814 !el local variables
6815       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
6816               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
6817
6818 ! Set lprn=.true. for debugging
6819       lprn=.false.
6820 #ifdef MPI
6821 !      maxconts=nres/4
6822       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6823       n_corr=0
6824       n_corr1=0
6825       if (nfgtasks.le.1) goto 30
6826       if (lprn) then
6827         write (iout,'(a)') 'Contact function values before RECEIVE:'
6828         do i=nnt,nct-2
6829           write (iout,'(2i3,50(1x,i2,f5.2))') &
6830           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6831           j=1,num_cont_hb(i))
6832         enddo
6833       endif
6834       call flush(iout)
6835       do i=1,ntask_cont_from
6836         ncont_recv(i)=0
6837       enddo
6838       do i=1,ntask_cont_to
6839         ncont_sent(i)=0
6840       enddo
6841 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6842 !     & ntask_cont_to
6843 ! Make the list of contacts to send to send to other procesors
6844 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6845 !      call flush(iout)
6846       do i=iturn3_start,iturn3_end
6847 !        write (iout,*) "make contact list turn3",i," num_cont",
6848 !     &    num_cont_hb(i)
6849         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6850       enddo
6851       do i=iturn4_start,iturn4_end
6852 !        write (iout,*) "make contact list turn4",i," num_cont",
6853 !     &   num_cont_hb(i)
6854         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6855       enddo
6856       do ii=1,nat_sent
6857         i=iat_sent(ii)
6858 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6859 !     &    num_cont_hb(i)
6860         do j=1,num_cont_hb(i)
6861         do k=1,4
6862           jjc=jcont_hb(j,i)
6863           iproc=iint_sent_local(k,jjc,ii)
6864 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6865           if (iproc.gt.0) then
6866             ncont_sent(iproc)=ncont_sent(iproc)+1
6867             nn=ncont_sent(iproc)
6868             zapas(1,nn,iproc)=i
6869             zapas(2,nn,iproc)=jjc
6870             zapas(3,nn,iproc)=facont_hb(j,i)
6871             zapas(4,nn,iproc)=ees0p(j,i)
6872             zapas(5,nn,iproc)=ees0m(j,i)
6873             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6874             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6875             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6876             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6877             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6878             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6879             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6880             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6881             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6882             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6883             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6884             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6885             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6886             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6887             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6888             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6889             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6890             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6891             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6892             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6893             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6894           endif
6895         enddo
6896         enddo
6897       enddo
6898       if (lprn) then
6899       write (iout,*) &
6900         "Numbers of contacts to be sent to other processors",&
6901         (ncont_sent(i),i=1,ntask_cont_to)
6902       write (iout,*) "Contacts sent"
6903       do ii=1,ntask_cont_to
6904         nn=ncont_sent(ii)
6905         iproc=itask_cont_to(ii)
6906         write (iout,*) nn," contacts to processor",iproc,&
6907          " of CONT_TO_COMM group"
6908         do i=1,nn
6909           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6910         enddo
6911       enddo
6912       call flush(iout)
6913       endif
6914       CorrelType=477
6915       CorrelID=fg_rank+1
6916       CorrelType1=478
6917       CorrelID1=nfgtasks+fg_rank+1
6918       ireq=0
6919 ! Receive the numbers of needed contacts from other processors
6920       do ii=1,ntask_cont_from
6921         iproc=itask_cont_from(ii)
6922         ireq=ireq+1
6923         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6924           FG_COMM,req(ireq),IERR)
6925       enddo
6926 !      write (iout,*) "IRECV ended"
6927 !      call flush(iout)
6928 ! Send the number of contacts needed by other processors
6929       do ii=1,ntask_cont_to
6930         iproc=itask_cont_to(ii)
6931         ireq=ireq+1
6932         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6933           FG_COMM,req(ireq),IERR)
6934       enddo
6935 !      write (iout,*) "ISEND ended"
6936 !      write (iout,*) "number of requests (nn)",ireq
6937       call flush(iout)
6938       if (ireq.gt.0) &
6939         call MPI_Waitall(ireq,req,status_array,ierr)
6940 !      write (iout,*)
6941 !     &  "Numbers of contacts to be received from other processors",
6942 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6943 !      call flush(iout)
6944 ! Receive contacts
6945       ireq=0
6946       do ii=1,ntask_cont_from
6947         iproc=itask_cont_from(ii)
6948         nn=ncont_recv(ii)
6949 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6950 !     &   " of CONT_TO_COMM group"
6951         call flush(iout)
6952         if (nn.gt.0) then
6953           ireq=ireq+1
6954           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6955           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6956 !          write (iout,*) "ireq,req",ireq,req(ireq)
6957         endif
6958       enddo
6959 ! Send the contacts to processors that need them
6960       do ii=1,ntask_cont_to
6961         iproc=itask_cont_to(ii)
6962         nn=ncont_sent(ii)
6963 !        write (iout,*) nn," contacts to processor",iproc,
6964 !     &   " of CONT_TO_COMM group"
6965         if (nn.gt.0) then
6966           ireq=ireq+1
6967           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6968             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6969 !          write (iout,*) "ireq,req",ireq,req(ireq)
6970 !          do i=1,nn
6971 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6972 !          enddo
6973         endif
6974       enddo
6975 !      write (iout,*) "number of requests (contacts)",ireq
6976 !      write (iout,*) "req",(req(i),i=1,4)
6977 !      call flush(iout)
6978       if (ireq.gt.0) &
6979        call MPI_Waitall(ireq,req,status_array,ierr)
6980       do iii=1,ntask_cont_from
6981         iproc=itask_cont_from(iii)
6982         nn=ncont_recv(iii)
6983         if (lprn) then
6984         write (iout,*) "Received",nn," contacts from processor",iproc,&
6985          " of CONT_FROM_COMM group"
6986         call flush(iout)
6987         do i=1,nn
6988           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6989         enddo
6990         call flush(iout)
6991         endif
6992         do i=1,nn
6993           ii=zapas_recv(1,i,iii)
6994 ! Flag the received contacts to prevent double-counting
6995           jj=-zapas_recv(2,i,iii)
6996 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6997 !          call flush(iout)
6998           nnn=num_cont_hb(ii)+1
6999           num_cont_hb(ii)=nnn
7000           jcont_hb(nnn,ii)=jj
7001           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7002           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7003           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7004           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7005           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7006           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7007           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7008           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7009           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7010           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7011           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7012           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7013           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7014           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7015           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7016           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7017           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7018           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7019           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7020           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7021           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7022           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7023           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7024           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7025         enddo
7026       enddo
7027       call flush(iout)
7028       if (lprn) then
7029         write (iout,'(a)') 'Contact function values after receive:'
7030         do i=nnt,nct-2
7031           write (iout,'(2i3,50(1x,i3,f5.2))') &
7032           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7033           j=1,num_cont_hb(i))
7034         enddo
7035         call flush(iout)
7036       endif
7037    30 continue
7038 #endif
7039       if (lprn) then
7040         write (iout,'(a)') 'Contact function values:'
7041         do i=nnt,nct-2
7042           write (iout,'(2i3,50(1x,i3,f5.2))') &
7043           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7044           j=1,num_cont_hb(i))
7045         enddo
7046       endif
7047       ecorr=0.0D0
7048
7049 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7050 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7051 ! Remove the loop below after debugging !!!
7052       do i=nnt,nct
7053         do j=1,3
7054           gradcorr(j,i)=0.0D0
7055           gradxorr(j,i)=0.0D0
7056         enddo
7057       enddo
7058 ! Calculate the local-electrostatic correlation terms
7059       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7060         i1=i+1
7061         num_conti=num_cont_hb(i)
7062         num_conti1=num_cont_hb(i+1)
7063         do jj=1,num_conti
7064           j=jcont_hb(jj,i)
7065           jp=iabs(j)
7066           do kk=1,num_conti1
7067             j1=jcont_hb(kk,i1)
7068             jp1=iabs(j1)
7069 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7070 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7071             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7072                 .or. j.lt.0 .and. j1.gt.0) .and. &
7073                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7074 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7075 ! The system gains extra energy.
7076               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7077               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7078                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7079               n_corr=n_corr+1
7080             else if (j1.eq.j) then
7081 ! Contacts I-J and I-(J+1) occur simultaneously.
7082 ! The system loses extra energy.
7083 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7084             endif
7085           enddo ! kk
7086           do kk=1,num_conti
7087             j1=jcont_hb(kk,i)
7088 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7089 !    &         ' jj=',jj,' kk=',kk
7090             if (j1.eq.j+1) then
7091 ! Contacts I-J and (I+1)-J occur simultaneously.
7092 ! The system loses extra energy.
7093 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7094             endif ! j1==j+1
7095           enddo ! kk
7096         enddo ! jj
7097       enddo ! i
7098       return
7099       end subroutine multibody_hb
7100 !-----------------------------------------------------------------------------
7101       subroutine add_hb_contact(ii,jj,itask)
7102 !      implicit real*8 (a-h,o-z)
7103 !      include "DIMENSIONS"
7104 !      include "COMMON.IOUNITS"
7105 !      include "COMMON.CONTACTS"
7106 !      integer,parameter :: maxconts=nres/4
7107       integer,parameter :: max_dim=26
7108       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7109 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7110 !      common /przechowalnia/ zapas
7111       integer :: i,j,ii,jj,iproc,nn,jjc
7112       integer,dimension(4) :: itask
7113 !      write (iout,*) "itask",itask
7114       do i=1,2
7115         iproc=itask(i)
7116         if (iproc.gt.0) then
7117           do j=1,num_cont_hb(ii)
7118             jjc=jcont_hb(j,ii)
7119 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7120             if (jjc.eq.jj) then
7121               ncont_sent(iproc)=ncont_sent(iproc)+1
7122               nn=ncont_sent(iproc)
7123               zapas(1,nn,iproc)=ii
7124               zapas(2,nn,iproc)=jjc
7125               zapas(3,nn,iproc)=facont_hb(j,ii)
7126               zapas(4,nn,iproc)=ees0p(j,ii)
7127               zapas(5,nn,iproc)=ees0m(j,ii)
7128               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7129               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7130               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7131               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7132               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7133               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7134               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7135               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7136               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7137               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7138               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7139               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7140               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7141               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7142               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7143               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7144               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7145               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7146               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7147               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7148               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7149               exit
7150             endif
7151           enddo
7152         endif
7153       enddo
7154       return
7155       end subroutine add_hb_contact
7156 !-----------------------------------------------------------------------------
7157       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7158 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7159 !      implicit real*8 (a-h,o-z)
7160 !      include 'DIMENSIONS'
7161 !      include 'COMMON.IOUNITS'
7162       integer,parameter :: max_dim=70
7163 #ifdef MPI
7164       include "mpif.h"
7165 !      integer :: maxconts !max_cont=maxconts=nres/4
7166       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7167       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7168 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7169 !      common /przechowalnia/ zapas
7170       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7171         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7172         ierr,iii,nnn
7173 #endif
7174 !      include 'COMMON.SETUP'
7175 !      include 'COMMON.FFIELD'
7176 !      include 'COMMON.DERIV'
7177 !      include 'COMMON.LOCAL'
7178 !      include 'COMMON.INTERACT'
7179 !      include 'COMMON.CONTACTS'
7180 !      include 'COMMON.CHAIN'
7181 !      include 'COMMON.CONTROL'
7182       real(kind=8),dimension(3) :: gx,gx1
7183       integer,dimension(nres) :: num_cont_hb_old
7184       logical :: lprn,ldone
7185 !EL      double precision eello4,eello5,eelo6,eello_turn6
7186 !EL      external eello4,eello5,eello6,eello_turn6
7187 !el local variables
7188       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7189               j1,jp1,i1,num_conti1
7190       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7191       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7192
7193 ! Set lprn=.true. for debugging
7194       lprn=.false.
7195       eturn6=0.0d0
7196 #ifdef MPI
7197 !      maxconts=nres/4
7198       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7199       do i=1,nres
7200         num_cont_hb_old(i)=num_cont_hb(i)
7201       enddo
7202       n_corr=0
7203       n_corr1=0
7204       if (nfgtasks.le.1) goto 30
7205       if (lprn) then
7206         write (iout,'(a)') 'Contact function values before RECEIVE:'
7207         do i=nnt,nct-2
7208           write (iout,'(2i3,50(1x,i2,f5.2))') &
7209           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7210           j=1,num_cont_hb(i))
7211         enddo
7212       endif
7213       call flush(iout)
7214       do i=1,ntask_cont_from
7215         ncont_recv(i)=0
7216       enddo
7217       do i=1,ntask_cont_to
7218         ncont_sent(i)=0
7219       enddo
7220 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7221 !     & ntask_cont_to
7222 ! Make the list of contacts to send to send to other procesors
7223       do i=iturn3_start,iturn3_end
7224 !        write (iout,*) "make contact list turn3",i," num_cont",
7225 !     &    num_cont_hb(i)
7226         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7227       enddo
7228       do i=iturn4_start,iturn4_end
7229 !        write (iout,*) "make contact list turn4",i," num_cont",
7230 !     &   num_cont_hb(i)
7231         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7232       enddo
7233       do ii=1,nat_sent
7234         i=iat_sent(ii)
7235 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7236 !     &    num_cont_hb(i)
7237         do j=1,num_cont_hb(i)
7238         do k=1,4
7239           jjc=jcont_hb(j,i)
7240           iproc=iint_sent_local(k,jjc,ii)
7241 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7242           if (iproc.ne.0) then
7243             ncont_sent(iproc)=ncont_sent(iproc)+1
7244             nn=ncont_sent(iproc)
7245             zapas(1,nn,iproc)=i
7246             zapas(2,nn,iproc)=jjc
7247             zapas(3,nn,iproc)=d_cont(j,i)
7248             ind=3
7249             do kk=1,3
7250               ind=ind+1
7251               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7252             enddo
7253             do kk=1,2
7254               do ll=1,2
7255                 ind=ind+1
7256                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7257               enddo
7258             enddo
7259             do jj=1,5
7260               do kk=1,3
7261                 do ll=1,2
7262                   do mm=1,2
7263                     ind=ind+1
7264                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7265                   enddo
7266                 enddo
7267               enddo
7268             enddo
7269           endif
7270         enddo
7271         enddo
7272       enddo
7273       if (lprn) then
7274       write (iout,*) &
7275         "Numbers of contacts to be sent to other processors",&
7276         (ncont_sent(i),i=1,ntask_cont_to)
7277       write (iout,*) "Contacts sent"
7278       do ii=1,ntask_cont_to
7279         nn=ncont_sent(ii)
7280         iproc=itask_cont_to(ii)
7281         write (iout,*) nn," contacts to processor",iproc,&
7282          " of CONT_TO_COMM group"
7283         do i=1,nn
7284           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7285         enddo
7286       enddo
7287       call flush(iout)
7288       endif
7289       CorrelType=477
7290       CorrelID=fg_rank+1
7291       CorrelType1=478
7292       CorrelID1=nfgtasks+fg_rank+1
7293       ireq=0
7294 ! Receive the numbers of needed contacts from other processors
7295       do ii=1,ntask_cont_from
7296         iproc=itask_cont_from(ii)
7297         ireq=ireq+1
7298         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7299           FG_COMM,req(ireq),IERR)
7300       enddo
7301 !      write (iout,*) "IRECV ended"
7302 !      call flush(iout)
7303 ! Send the number of contacts needed by other processors
7304       do ii=1,ntask_cont_to
7305         iproc=itask_cont_to(ii)
7306         ireq=ireq+1
7307         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7308           FG_COMM,req(ireq),IERR)
7309       enddo
7310 !      write (iout,*) "ISEND ended"
7311 !      write (iout,*) "number of requests (nn)",ireq
7312       call flush(iout)
7313       if (ireq.gt.0) &
7314         call MPI_Waitall(ireq,req,status_array,ierr)
7315 !      write (iout,*)
7316 !     &  "Numbers of contacts to be received from other processors",
7317 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7318 !      call flush(iout)
7319 ! Receive contacts
7320       ireq=0
7321       do ii=1,ntask_cont_from
7322         iproc=itask_cont_from(ii)
7323         nn=ncont_recv(ii)
7324 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7325 !     &   " of CONT_TO_COMM group"
7326         call flush(iout)
7327         if (nn.gt.0) then
7328           ireq=ireq+1
7329           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7330           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7331 !          write (iout,*) "ireq,req",ireq,req(ireq)
7332         endif
7333       enddo
7334 ! Send the contacts to processors that need them
7335       do ii=1,ntask_cont_to
7336         iproc=itask_cont_to(ii)
7337         nn=ncont_sent(ii)
7338 !        write (iout,*) nn," contacts to processor",iproc,
7339 !     &   " of CONT_TO_COMM group"
7340         if (nn.gt.0) then
7341           ireq=ireq+1
7342           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7343             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7344 !          write (iout,*) "ireq,req",ireq,req(ireq)
7345 !          do i=1,nn
7346 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7347 !          enddo
7348         endif
7349       enddo
7350 !      write (iout,*) "number of requests (contacts)",ireq
7351 !      write (iout,*) "req",(req(i),i=1,4)
7352 !      call flush(iout)
7353       if (ireq.gt.0) &
7354        call MPI_Waitall(ireq,req,status_array,ierr)
7355       do iii=1,ntask_cont_from
7356         iproc=itask_cont_from(iii)
7357         nn=ncont_recv(iii)
7358         if (lprn) then
7359         write (iout,*) "Received",nn," contacts from processor",iproc,&
7360          " of CONT_FROM_COMM group"
7361         call flush(iout)
7362         do i=1,nn
7363           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7364         enddo
7365         call flush(iout)
7366         endif
7367         do i=1,nn
7368           ii=zapas_recv(1,i,iii)
7369 ! Flag the received contacts to prevent double-counting
7370           jj=-zapas_recv(2,i,iii)
7371 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7372 !          call flush(iout)
7373           nnn=num_cont_hb(ii)+1
7374           num_cont_hb(ii)=nnn
7375           jcont_hb(nnn,ii)=jj
7376           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7377           ind=3
7378           do kk=1,3
7379             ind=ind+1
7380             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7381           enddo
7382           do kk=1,2
7383             do ll=1,2
7384               ind=ind+1
7385               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7386             enddo
7387           enddo
7388           do jj=1,5
7389             do kk=1,3
7390               do ll=1,2
7391                 do mm=1,2
7392                   ind=ind+1
7393                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7394                 enddo
7395               enddo
7396             enddo
7397           enddo
7398         enddo
7399       enddo
7400       call flush(iout)
7401       if (lprn) then
7402         write (iout,'(a)') 'Contact function values after receive:'
7403         do i=nnt,nct-2
7404           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7405           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7406           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7407         enddo
7408         call flush(iout)
7409       endif
7410    30 continue
7411 #endif
7412       if (lprn) then
7413         write (iout,'(a)') 'Contact function values:'
7414         do i=nnt,nct-2
7415           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7416           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7417           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7418         enddo
7419       endif
7420       ecorr=0.0D0
7421       ecorr5=0.0d0
7422       ecorr6=0.0d0
7423
7424 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7425 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7426 ! Remove the loop below after debugging !!!
7427       do i=nnt,nct
7428         do j=1,3
7429           gradcorr(j,i)=0.0D0
7430           gradxorr(j,i)=0.0D0
7431         enddo
7432       enddo
7433 ! Calculate the dipole-dipole interaction energies
7434       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7435       do i=iatel_s,iatel_e+1
7436         num_conti=num_cont_hb(i)
7437         do jj=1,num_conti
7438           j=jcont_hb(jj,i)
7439 #ifdef MOMENT
7440           call dipole(i,j,jj)
7441 #endif
7442         enddo
7443       enddo
7444       endif
7445 ! Calculate the local-electrostatic correlation terms
7446 !                write (iout,*) "gradcorr5 in eello5 before loop"
7447 !                do iii=1,nres
7448 !                  write (iout,'(i5,3f10.5)')
7449 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7450 !                enddo
7451       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7452 !        write (iout,*) "corr loop i",i
7453         i1=i+1
7454         num_conti=num_cont_hb(i)
7455         num_conti1=num_cont_hb(i+1)
7456         do jj=1,num_conti
7457           j=jcont_hb(jj,i)
7458           jp=iabs(j)
7459           do kk=1,num_conti1
7460             j1=jcont_hb(kk,i1)
7461             jp1=iabs(j1)
7462 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7463 !     &         ' jj=',jj,' kk=',kk
7464 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7465             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7466                 .or. j.lt.0 .and. j1.gt.0) .and. &
7467                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7468 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7469 ! The system gains extra energy.
7470               n_corr=n_corr+1
7471               sqd1=dsqrt(d_cont(jj,i))
7472               sqd2=dsqrt(d_cont(kk,i1))
7473               sred_geom = sqd1*sqd2
7474               IF (sred_geom.lt.cutoff_corr) THEN
7475                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7476                   ekont,fprimcont)
7477 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7478 !d     &         ' jj=',jj,' kk=',kk
7479                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7480                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7481                 do l=1,3
7482                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7483                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7484                 enddo
7485                 n_corr1=n_corr1+1
7486 !d               write (iout,*) 'sred_geom=',sred_geom,
7487 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7488 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7489 !d               write (iout,*) "g_contij",g_contij
7490 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7491 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7492                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7493                 if (wcorr4.gt.0.0d0) &
7494                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7495                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7496                        write (iout,'(a6,4i5,0pf7.3)') &
7497                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7498 !                write (iout,*) "gradcorr5 before eello5"
7499 !                do iii=1,nres
7500 !                  write (iout,'(i5,3f10.5)')
7501 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7502 !                enddo
7503                 if (wcorr5.gt.0.0d0) &
7504                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7505 !                write (iout,*) "gradcorr5 after eello5"
7506 !                do iii=1,nres
7507 !                  write (iout,'(i5,3f10.5)')
7508 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7509 !                enddo
7510                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7511                        write (iout,'(a6,4i5,0pf7.3)') &
7512                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7513 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7514 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7515                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7516                      .or. wturn6.eq.0.0d0))then
7517 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7518                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7519                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7520                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7521 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7522 !d     &            'ecorr6=',ecorr6
7523 !d                write (iout,'(4e15.5)') sred_geom,
7524 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7525 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7526 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7527                 else if (wturn6.gt.0.0d0 &
7528                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7529 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7530                   eturn6=eturn6+eello_turn6(i,jj,kk)
7531                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7532                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7533 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7534                 endif
7535               ENDIF
7536 1111          continue
7537             endif
7538           enddo ! kk
7539         enddo ! jj
7540       enddo ! i
7541       do i=1,nres
7542         num_cont_hb(i)=num_cont_hb_old(i)
7543       enddo
7544 !                write (iout,*) "gradcorr5 in eello5"
7545 !                do iii=1,nres
7546 !                  write (iout,'(i5,3f10.5)')
7547 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7548 !                enddo
7549       return
7550       end subroutine multibody_eello
7551 !-----------------------------------------------------------------------------
7552       subroutine add_hb_contact_eello(ii,jj,itask)
7553 !      implicit real*8 (a-h,o-z)
7554 !      include "DIMENSIONS"
7555 !      include "COMMON.IOUNITS"
7556 !      include "COMMON.CONTACTS"
7557 !      integer,parameter :: maxconts=nres/4
7558       integer,parameter :: max_dim=70
7559       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7560 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7561 !      common /przechowalnia/ zapas
7562
7563       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7564       integer,dimension(4) ::itask
7565 !      write (iout,*) "itask",itask
7566       do i=1,2
7567         iproc=itask(i)
7568         if (iproc.gt.0) then
7569           do j=1,num_cont_hb(ii)
7570             jjc=jcont_hb(j,ii)
7571 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7572             if (jjc.eq.jj) then
7573               ncont_sent(iproc)=ncont_sent(iproc)+1
7574               nn=ncont_sent(iproc)
7575               zapas(1,nn,iproc)=ii
7576               zapas(2,nn,iproc)=jjc
7577               zapas(3,nn,iproc)=d_cont(j,ii)
7578               ind=3
7579               do kk=1,3
7580                 ind=ind+1
7581                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7582               enddo
7583               do kk=1,2
7584                 do ll=1,2
7585                   ind=ind+1
7586                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7587                 enddo
7588               enddo
7589               do jj=1,5
7590                 do kk=1,3
7591                   do ll=1,2
7592                     do mm=1,2
7593                       ind=ind+1
7594                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7595                     enddo
7596                   enddo
7597                 enddo
7598               enddo
7599               exit
7600             endif
7601           enddo
7602         endif
7603       enddo
7604       return
7605       end subroutine add_hb_contact_eello
7606 !-----------------------------------------------------------------------------
7607       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7608 !      implicit real*8 (a-h,o-z)
7609 !      include 'DIMENSIONS'
7610 !      include 'COMMON.IOUNITS'
7611 !      include 'COMMON.DERIV'
7612 !      include 'COMMON.INTERACT'
7613 !      include 'COMMON.CONTACTS'
7614       real(kind=8),dimension(3) :: gx,gx1
7615       logical :: lprn
7616 !el local variables
7617       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
7618       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
7619                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
7620                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
7621                    rlocshield
7622
7623       lprn=.false.
7624       eij=facont_hb(jj,i)
7625       ekl=facont_hb(kk,k)
7626       ees0pij=ees0p(jj,i)
7627       ees0pkl=ees0p(kk,k)
7628       ees0mij=ees0m(jj,i)
7629       ees0mkl=ees0m(kk,k)
7630       ekont=eij*ekl
7631       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7632 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7633 ! Following 4 lines for diagnostics.
7634 !d    ees0pkl=0.0D0
7635 !d    ees0pij=1.0D0
7636 !d    ees0mkl=0.0D0
7637 !d    ees0mij=1.0D0
7638 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7639 !     & 'Contacts ',i,j,
7640 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7641 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7642 !     & 'gradcorr_long'
7643 ! Calculate the multi-body contribution to energy.
7644 !      ecorr=ecorr+ekont*ees
7645 ! Calculate multi-body contributions to the gradient.
7646       coeffpees0pij=coeffp*ees0pij
7647       coeffmees0mij=coeffm*ees0mij
7648       coeffpees0pkl=coeffp*ees0pkl
7649       coeffmees0mkl=coeffm*ees0mkl
7650       do ll=1,3
7651 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7652         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
7653         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
7654         coeffmees0mkl*gacontm_hb1(ll,jj,i))
7655         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
7656         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
7657         coeffmees0mkl*gacontm_hb2(ll,jj,i))
7658 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7659         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
7660         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
7661         coeffmees0mij*gacontm_hb1(ll,kk,k))
7662         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
7663         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
7664         coeffmees0mij*gacontm_hb2(ll,kk,k))
7665         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
7666            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
7667            coeffmees0mkl*gacontm_hb3(ll,jj,i))
7668         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7669         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7670         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
7671            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
7672            coeffmees0mij*gacontm_hb3(ll,kk,k))
7673         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7674         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7675 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7676       enddo
7677 !      write (iout,*)
7678 !grad      do m=i+1,j-1
7679 !grad        do ll=1,3
7680 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7681 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7682 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7683 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7684 !grad        enddo
7685 !grad      enddo
7686 !grad      do m=k+1,l-1
7687 !grad        do ll=1,3
7688 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7689 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
7690 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7691 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7692 !grad        enddo
7693 !grad      enddo
7694 !      write (iout,*) "ehbcorr",ekont*ees
7695       ehbcorr=ekont*ees
7696       if (shield_mode.gt.0) then
7697        j=ees0plist(jj,i)
7698        l=ees0plist(kk,k)
7699 !C        print *,i,j,fac_shield(i),fac_shield(j),
7700 !C     &fac_shield(k),fac_shield(l)
7701         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
7702            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7703           do ilist=1,ishield_list(i)
7704            iresshield=shield_list(ilist,i)
7705            do m=1,3
7706            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7707            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7708                    rlocshield  &
7709             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7710             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7711             +rlocshield
7712            enddo
7713           enddo
7714           do ilist=1,ishield_list(j)
7715            iresshield=shield_list(ilist,j)
7716            do m=1,3
7717            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7718            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7719                    rlocshield &
7720             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7721            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7722             +rlocshield
7723            enddo
7724           enddo
7725
7726           do ilist=1,ishield_list(k)
7727            iresshield=shield_list(ilist,k)
7728            do m=1,3
7729            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7730            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7731                    rlocshield &
7732             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7733            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7734             +rlocshield
7735            enddo
7736           enddo
7737           do ilist=1,ishield_list(l)
7738            iresshield=shield_list(ilist,l)
7739            do m=1,3
7740            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7741            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7742                    rlocshield &
7743             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7744            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7745             +rlocshield
7746            enddo
7747           enddo
7748           do m=1,3
7749             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
7750                    grad_shield(m,i)*ehbcorr/fac_shield(i)
7751             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
7752                    grad_shield(m,j)*ehbcorr/fac_shield(j)
7753             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
7754                    grad_shield(m,i)*ehbcorr/fac_shield(i)
7755             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
7756                    grad_shield(m,j)*ehbcorr/fac_shield(j)
7757
7758             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
7759                    grad_shield(m,k)*ehbcorr/fac_shield(k)
7760             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
7761                    grad_shield(m,l)*ehbcorr/fac_shield(l)
7762             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
7763                    grad_shield(m,k)*ehbcorr/fac_shield(k)
7764             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
7765                    grad_shield(m,l)*ehbcorr/fac_shield(l)
7766
7767            enddo
7768       endif
7769       endif
7770       return
7771       end function ehbcorr
7772 #ifdef MOMENT
7773 !-----------------------------------------------------------------------------
7774       subroutine dipole(i,j,jj)
7775 !      implicit real*8 (a-h,o-z)
7776 !      include 'DIMENSIONS'
7777 !      include 'COMMON.IOUNITS'
7778 !      include 'COMMON.CHAIN'
7779 !      include 'COMMON.FFIELD'
7780 !      include 'COMMON.DERIV'
7781 !      include 'COMMON.INTERACT'
7782 !      include 'COMMON.CONTACTS'
7783 !      include 'COMMON.TORSION'
7784 !      include 'COMMON.VAR'
7785 !      include 'COMMON.GEO'
7786       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
7787       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
7788       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
7789
7790       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
7791       allocate(dipderx(3,5,4,maxconts,nres))
7792 !
7793
7794       iti1 = itortyp(itype(i+1))
7795       if (j.lt.nres-1) then
7796         itj1 = itortyp(itype(j+1))
7797       else
7798         itj1=ntortyp+1
7799       endif
7800       do iii=1,2
7801         dipi(iii,1)=Ub2(iii,i)
7802         dipderi(iii)=Ub2der(iii,i)
7803         dipi(iii,2)=b1(iii,iti1)
7804         dipj(iii,1)=Ub2(iii,j)
7805         dipderj(iii)=Ub2der(iii,j)
7806         dipj(iii,2)=b1(iii,itj1)
7807       enddo
7808       kkk=0
7809       do iii=1,2
7810         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7811         do jjj=1,2
7812           kkk=kkk+1
7813           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7814         enddo
7815       enddo
7816       do kkk=1,5
7817         do lll=1,3
7818           mmm=0
7819           do iii=1,2
7820             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
7821               auxvec(1))
7822             do jjj=1,2
7823               mmm=mmm+1
7824               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7825             enddo
7826           enddo
7827         enddo
7828       enddo
7829       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7830       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7831       do iii=1,2
7832         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7833       enddo
7834       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7835       do iii=1,2
7836         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7837       enddo
7838       return
7839       end subroutine dipole
7840 #endif
7841 !-----------------------------------------------------------------------------
7842       subroutine calc_eello(i,j,k,l,jj,kk)
7843 !
7844 ! This subroutine computes matrices and vectors needed to calculate
7845 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
7846 !
7847       use comm_kut
7848 !      implicit real*8 (a-h,o-z)
7849 !      include 'DIMENSIONS'
7850 !      include 'COMMON.IOUNITS'
7851 !      include 'COMMON.CHAIN'
7852 !      include 'COMMON.DERIV'
7853 !      include 'COMMON.INTERACT'
7854 !      include 'COMMON.CONTACTS'
7855 !      include 'COMMON.TORSION'
7856 !      include 'COMMON.VAR'
7857 !      include 'COMMON.GEO'
7858 !      include 'COMMON.FFIELD'
7859       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
7860       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
7861       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
7862               itj1
7863 !el      logical :: lprn
7864 !el      common /kutas/ lprn
7865 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7866 !d     & ' jj=',jj,' kk=',kk
7867 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7868 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7869 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7870       do iii=1,2
7871         do jjj=1,2
7872           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7873           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7874         enddo
7875       enddo
7876       call transpose2(aa1(1,1),aa1t(1,1))
7877       call transpose2(aa2(1,1),aa2t(1,1))
7878       do kkk=1,5
7879         do lll=1,3
7880           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
7881             aa1tder(1,1,lll,kkk))
7882           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
7883             aa2tder(1,1,lll,kkk))
7884         enddo
7885       enddo
7886       if (l.eq.j+1) then
7887 ! parallel orientation of the two CA-CA-CA frames.
7888         if (i.gt.1) then
7889           iti=itortyp(itype(i))
7890         else
7891           iti=ntortyp+1
7892         endif
7893         itk1=itortyp(itype(k+1))
7894         itj=itortyp(itype(j))
7895         if (l.lt.nres-1) then
7896           itl1=itortyp(itype(l+1))
7897         else
7898           itl1=ntortyp+1
7899         endif
7900 ! A1 kernel(j+1) A2T
7901 !d        do iii=1,2
7902 !d          write (iout,'(3f10.5,5x,3f10.5)')
7903 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7904 !d        enddo
7905         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7906          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
7907          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7908 ! Following matrices are needed only for 6-th order cumulants
7909         IF (wcorr6.gt.0.0d0) THEN
7910         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7911          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
7912          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7913         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7914          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
7915          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7916          ADtEAderx(1,1,1,1,1,1))
7917         lprn=.false.
7918         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7919          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
7920          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7921          ADtEA1derx(1,1,1,1,1,1))
7922         ENDIF
7923 ! End 6-th order cumulants
7924 !d        lprn=.false.
7925 !d        if (lprn) then
7926 !d        write (2,*) 'In calc_eello6'
7927 !d        do iii=1,2
7928 !d          write (2,*) 'iii=',iii
7929 !d          do kkk=1,5
7930 !d            write (2,*) 'kkk=',kkk
7931 !d            do jjj=1,2
7932 !d              write (2,'(3(2f10.5),5x)')
7933 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7934 !d            enddo
7935 !d          enddo
7936 !d        enddo
7937 !d        endif
7938         call transpose2(EUgder(1,1,k),auxmat(1,1))
7939         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7940         call transpose2(EUg(1,1,k),auxmat(1,1))
7941         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7942         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7943         do iii=1,2
7944           do kkk=1,5
7945             do lll=1,3
7946               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7947                 EAEAderx(1,1,lll,kkk,iii,1))
7948             enddo
7949           enddo
7950         enddo
7951 ! A1T kernel(i+1) A2
7952         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7953          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
7954          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7955 ! Following matrices are needed only for 6-th order cumulants
7956         IF (wcorr6.gt.0.0d0) THEN
7957         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7958          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
7959          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7960         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7961          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
7962          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7963          ADtEAderx(1,1,1,1,1,2))
7964         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7965          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
7966          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7967          ADtEA1derx(1,1,1,1,1,2))
7968         ENDIF
7969 ! End 6-th order cumulants
7970         call transpose2(EUgder(1,1,l),auxmat(1,1))
7971         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7972         call transpose2(EUg(1,1,l),auxmat(1,1))
7973         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7974         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7975         do iii=1,2
7976           do kkk=1,5
7977             do lll=1,3
7978               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7979                 EAEAderx(1,1,lll,kkk,iii,2))
7980             enddo
7981           enddo
7982         enddo
7983 ! AEAb1 and AEAb2
7984 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7985 ! They are needed only when the fifth- or the sixth-order cumulants are
7986 ! indluded.
7987         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7988         call transpose2(AEA(1,1,1),auxmat(1,1))
7989         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7990         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7991         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7992         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7993         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7994         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7995         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7996         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7997         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7998         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7999         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8000         call transpose2(AEA(1,1,2),auxmat(1,1))
8001         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8002         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8003         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8004         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8005         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8006         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8007         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8008         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8009         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8010         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8011         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8012 ! Calculate the Cartesian derivatives of the vectors.
8013         do iii=1,2
8014           do kkk=1,5
8015             do lll=1,3
8016               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8017               call matvec2(auxmat(1,1),b1(1,iti),&
8018                 AEAb1derx(1,lll,kkk,iii,1,1))
8019               call matvec2(auxmat(1,1),Ub2(1,i),&
8020                 AEAb2derx(1,lll,kkk,iii,1,1))
8021               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8022                 AEAb1derx(1,lll,kkk,iii,2,1))
8023               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8024                 AEAb2derx(1,lll,kkk,iii,2,1))
8025               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8026               call matvec2(auxmat(1,1),b1(1,itj),&
8027                 AEAb1derx(1,lll,kkk,iii,1,2))
8028               call matvec2(auxmat(1,1),Ub2(1,j),&
8029                 AEAb2derx(1,lll,kkk,iii,1,2))
8030               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8031                 AEAb1derx(1,lll,kkk,iii,2,2))
8032               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8033                 AEAb2derx(1,lll,kkk,iii,2,2))
8034             enddo
8035           enddo
8036         enddo
8037         ENDIF
8038 ! End vectors
8039       else
8040 ! Antiparallel orientation of the two CA-CA-CA frames.
8041         if (i.gt.1) then
8042           iti=itortyp(itype(i))
8043         else
8044           iti=ntortyp+1
8045         endif
8046         itk1=itortyp(itype(k+1))
8047         itl=itortyp(itype(l))
8048         itj=itortyp(itype(j))
8049         if (j.lt.nres-1) then
8050           itj1=itortyp(itype(j+1))
8051         else
8052           itj1=ntortyp+1
8053         endif
8054 ! A2 kernel(j-1)T A1T
8055         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8056          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8057          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8058 ! Following matrices are needed only for 6-th order cumulants
8059         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8060            j.eq.i+4 .and. l.eq.i+3)) THEN
8061         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8062          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8063          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8064         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8065          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8066          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8067          ADtEAderx(1,1,1,1,1,1))
8068         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8069          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8070          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8071          ADtEA1derx(1,1,1,1,1,1))
8072         ENDIF
8073 ! End 6-th order cumulants
8074         call transpose2(EUgder(1,1,k),auxmat(1,1))
8075         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8076         call transpose2(EUg(1,1,k),auxmat(1,1))
8077         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8078         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8079         do iii=1,2
8080           do kkk=1,5
8081             do lll=1,3
8082               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8083                 EAEAderx(1,1,lll,kkk,iii,1))
8084             enddo
8085           enddo
8086         enddo
8087 ! A2T kernel(i+1)T A1
8088         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8089          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8090          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8091 ! Following matrices are needed only for 6-th order cumulants
8092         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8093            j.eq.i+4 .and. l.eq.i+3)) THEN
8094         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8095          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8096          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8097         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8098          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8099          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8100          ADtEAderx(1,1,1,1,1,2))
8101         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8102          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8103          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8104          ADtEA1derx(1,1,1,1,1,2))
8105         ENDIF
8106 ! End 6-th order cumulants
8107         call transpose2(EUgder(1,1,j),auxmat(1,1))
8108         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8109         call transpose2(EUg(1,1,j),auxmat(1,1))
8110         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8111         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8112         do iii=1,2
8113           do kkk=1,5
8114             do lll=1,3
8115               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8116                 EAEAderx(1,1,lll,kkk,iii,2))
8117             enddo
8118           enddo
8119         enddo
8120 ! AEAb1 and AEAb2
8121 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8122 ! They are needed only when the fifth- or the sixth-order cumulants are
8123 ! indluded.
8124         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8125           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8126         call transpose2(AEA(1,1,1),auxmat(1,1))
8127         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8128         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8129         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8130         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8131         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8132         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8133         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8134         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8135         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8136         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8137         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8138         call transpose2(AEA(1,1,2),auxmat(1,1))
8139         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8140         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8141         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8142         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8143         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8144         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8145         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8146         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8147         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8148         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8149         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8150 ! Calculate the Cartesian derivatives of the vectors.
8151         do iii=1,2
8152           do kkk=1,5
8153             do lll=1,3
8154               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8155               call matvec2(auxmat(1,1),b1(1,iti),&
8156                 AEAb1derx(1,lll,kkk,iii,1,1))
8157               call matvec2(auxmat(1,1),Ub2(1,i),&
8158                 AEAb2derx(1,lll,kkk,iii,1,1))
8159               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8160                 AEAb1derx(1,lll,kkk,iii,2,1))
8161               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8162                 AEAb2derx(1,lll,kkk,iii,2,1))
8163               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8164               call matvec2(auxmat(1,1),b1(1,itl),&
8165                 AEAb1derx(1,lll,kkk,iii,1,2))
8166               call matvec2(auxmat(1,1),Ub2(1,l),&
8167                 AEAb2derx(1,lll,kkk,iii,1,2))
8168               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8169                 AEAb1derx(1,lll,kkk,iii,2,2))
8170               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8171                 AEAb2derx(1,lll,kkk,iii,2,2))
8172             enddo
8173           enddo
8174         enddo
8175         ENDIF
8176 ! End vectors
8177       endif
8178       return
8179       end subroutine calc_eello
8180 !-----------------------------------------------------------------------------
8181       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8182       use comm_kut
8183       implicit none
8184       integer :: nderg
8185       logical :: transp
8186       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8187       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8188       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8189       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8190       integer :: iii,kkk,lll
8191       integer :: jjj,mmm
8192 !el      logical :: lprn
8193 !el      common /kutas/ lprn
8194       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8195       do iii=1,nderg
8196         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8197           AKAderg(1,1,iii))
8198       enddo
8199 !d      if (lprn) write (2,*) 'In kernel'
8200       do kkk=1,5
8201 !d        if (lprn) write (2,*) 'kkk=',kkk
8202         do lll=1,3
8203           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8204             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8205 !d          if (lprn) then
8206 !d            write (2,*) 'lll=',lll
8207 !d            write (2,*) 'iii=1'
8208 !d            do jjj=1,2
8209 !d              write (2,'(3(2f10.5),5x)')
8210 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8211 !d            enddo
8212 !d          endif
8213           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8214             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8215 !d          if (lprn) then
8216 !d            write (2,*) 'lll=',lll
8217 !d            write (2,*) 'iii=2'
8218 !d            do jjj=1,2
8219 !d              write (2,'(3(2f10.5),5x)')
8220 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8221 !d            enddo
8222 !d          endif
8223         enddo
8224       enddo
8225       return
8226       end subroutine kernel
8227 !-----------------------------------------------------------------------------
8228       real(kind=8) function eello4(i,j,k,l,jj,kk)
8229 !      implicit real*8 (a-h,o-z)
8230 !      include 'DIMENSIONS'
8231 !      include 'COMMON.IOUNITS'
8232 !      include 'COMMON.CHAIN'
8233 !      include 'COMMON.DERIV'
8234 !      include 'COMMON.INTERACT'
8235 !      include 'COMMON.CONTACTS'
8236 !      include 'COMMON.TORSION'
8237 !      include 'COMMON.VAR'
8238 !      include 'COMMON.GEO'
8239       real(kind=8),dimension(2,2) :: pizda
8240       real(kind=8),dimension(3) :: ggg1,ggg2
8241       real(kind=8) ::  eel4,glongij,glongkl
8242       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8243 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8244 !d        eello4=0.0d0
8245 !d        return
8246 !d      endif
8247 !d      print *,'eello4:',i,j,k,l,jj,kk
8248 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8249 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8250 !old      eij=facont_hb(jj,i)
8251 !old      ekl=facont_hb(kk,k)
8252 !old      ekont=eij*ekl
8253       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8254 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8255       gcorr_loc(k-1)=gcorr_loc(k-1) &
8256          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8257       if (l.eq.j+1) then
8258         gcorr_loc(l-1)=gcorr_loc(l-1) &
8259            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8260       else
8261         gcorr_loc(j-1)=gcorr_loc(j-1) &
8262            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8263       endif
8264       do iii=1,2
8265         do kkk=1,5
8266           do lll=1,3
8267             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8268                               -EAEAderx(2,2,lll,kkk,iii,1)
8269 !d            derx(lll,kkk,iii)=0.0d0
8270           enddo
8271         enddo
8272       enddo
8273 !d      gcorr_loc(l-1)=0.0d0
8274 !d      gcorr_loc(j-1)=0.0d0
8275 !d      gcorr_loc(k-1)=0.0d0
8276 !d      eel4=1.0d0
8277 !d      write (iout,*)'Contacts have occurred for peptide groups',
8278 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8279 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8280       if (j.lt.nres-1) then
8281         j1=j+1
8282         j2=j-1
8283       else
8284         j1=j-1
8285         j2=j-2
8286       endif
8287       if (l.lt.nres-1) then
8288         l1=l+1
8289         l2=l-1
8290       else
8291         l1=l-1
8292         l2=l-2
8293       endif
8294       do ll=1,3
8295 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8296 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8297         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8298         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8299 !grad        ghalf=0.5d0*ggg1(ll)
8300         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8301         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8302         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8303         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8304         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8305         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8306 !grad        ghalf=0.5d0*ggg2(ll)
8307         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8308         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8309         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8310         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8311         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8312         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8313       enddo
8314 !grad      do m=i+1,j-1
8315 !grad        do ll=1,3
8316 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8317 !grad        enddo
8318 !grad      enddo
8319 !grad      do m=k+1,l-1
8320 !grad        do ll=1,3
8321 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8322 !grad        enddo
8323 !grad      enddo
8324 !grad      do m=i+2,j2
8325 !grad        do ll=1,3
8326 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8327 !grad        enddo
8328 !grad      enddo
8329 !grad      do m=k+2,l2
8330 !grad        do ll=1,3
8331 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8332 !grad        enddo
8333 !grad      enddo
8334 !d      do iii=1,nres-3
8335 !d        write (2,*) iii,gcorr_loc(iii)
8336 !d      enddo
8337       eello4=ekont*eel4
8338 !d      write (2,*) 'ekont',ekont
8339 !d      write (iout,*) 'eello4',ekont*eel4
8340       return
8341       end function eello4
8342 !-----------------------------------------------------------------------------
8343       real(kind=8) function eello5(i,j,k,l,jj,kk)
8344 !      implicit real*8 (a-h,o-z)
8345 !      include 'DIMENSIONS'
8346 !      include 'COMMON.IOUNITS'
8347 !      include 'COMMON.CHAIN'
8348 !      include 'COMMON.DERIV'
8349 !      include 'COMMON.INTERACT'
8350 !      include 'COMMON.CONTACTS'
8351 !      include 'COMMON.TORSION'
8352 !      include 'COMMON.VAR'
8353 !      include 'COMMON.GEO'
8354       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8355       real(kind=8),dimension(2) :: vv
8356       real(kind=8),dimension(3) :: ggg1,ggg2
8357       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8358       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8359       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8360 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8361 !                                                                              C
8362 !                            Parallel chains                                   C
8363 !                                                                              C
8364 !          o             o                   o             o                   C
8365 !         /l\           / \             \   / \           / \   /              C
8366 !        /   \         /   \             \ /   \         /   \ /               C
8367 !       j| o |l1       | o |              o| o |         | o |o                C
8368 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8369 !      \i/   \         /   \ /             /   \         /   \                 C
8370 !       o    k1             o                                                  C
8371 !         (I)          (II)                (III)          (IV)                 C
8372 !                                                                              C
8373 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8374 !                                                                              C
8375 !                            Antiparallel chains                               C
8376 !                                                                              C
8377 !          o             o                   o             o                   C
8378 !         /j\           / \             \   / \           / \   /              C
8379 !        /   \         /   \             \ /   \         /   \ /               C
8380 !      j1| o |l        | o |              o| o |         | o |o                C
8381 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8382 !      \i/   \         /   \ /             /   \         /   \                 C
8383 !       o     k1            o                                                  C
8384 !         (I)          (II)                (III)          (IV)                 C
8385 !                                                                              C
8386 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8387 !                                                                              C
8388 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8389 !                                                                              C
8390 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8391 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8392 !d        eello5=0.0d0
8393 !d        return
8394 !d      endif
8395 !d      write (iout,*)
8396 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8397 !d     &   ' and',k,l
8398       itk=itortyp(itype(k))
8399       itl=itortyp(itype(l))
8400       itj=itortyp(itype(j))
8401       eello5_1=0.0d0
8402       eello5_2=0.0d0
8403       eello5_3=0.0d0
8404       eello5_4=0.0d0
8405 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8406 !d     &   eel5_3_num,eel5_4_num)
8407       do iii=1,2
8408         do kkk=1,5
8409           do lll=1,3
8410             derx(lll,kkk,iii)=0.0d0
8411           enddo
8412         enddo
8413       enddo
8414 !d      eij=facont_hb(jj,i)
8415 !d      ekl=facont_hb(kk,k)
8416 !d      ekont=eij*ekl
8417 !d      write (iout,*)'Contacts have occurred for peptide groups',
8418 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8419 !d      goto 1111
8420 ! Contribution from the graph I.
8421 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8422 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8423       call transpose2(EUg(1,1,k),auxmat(1,1))
8424       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8425       vv(1)=pizda(1,1)-pizda(2,2)
8426       vv(2)=pizda(1,2)+pizda(2,1)
8427       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8428        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8429 ! Explicit gradient in virtual-dihedral angles.
8430       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8431        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8432        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8433       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8434       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8435       vv(1)=pizda(1,1)-pizda(2,2)
8436       vv(2)=pizda(1,2)+pizda(2,1)
8437       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8438        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8439        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8440       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8441       vv(1)=pizda(1,1)-pizda(2,2)
8442       vv(2)=pizda(1,2)+pizda(2,1)
8443       if (l.eq.j+1) then
8444         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8445          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8446          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8447       else
8448         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8449          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8450          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8451       endif
8452 ! Cartesian gradient
8453       do iii=1,2
8454         do kkk=1,5
8455           do lll=1,3
8456             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8457               pizda(1,1))
8458             vv(1)=pizda(1,1)-pizda(2,2)
8459             vv(2)=pizda(1,2)+pizda(2,1)
8460             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8461              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8462              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8463           enddo
8464         enddo
8465       enddo
8466 !      goto 1112
8467 !1111  continue
8468 ! Contribution from graph II
8469       call transpose2(EE(1,1,itk),auxmat(1,1))
8470       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8471       vv(1)=pizda(1,1)+pizda(2,2)
8472       vv(2)=pizda(2,1)-pizda(1,2)
8473       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8474        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8475 ! Explicit gradient in virtual-dihedral angles.
8476       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8477        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8478       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8479       vv(1)=pizda(1,1)+pizda(2,2)
8480       vv(2)=pizda(2,1)-pizda(1,2)
8481       if (l.eq.j+1) then
8482         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8483          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8484          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8485       else
8486         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8487          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8488          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8489       endif
8490 ! Cartesian gradient
8491       do iii=1,2
8492         do kkk=1,5
8493           do lll=1,3
8494             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8495               pizda(1,1))
8496             vv(1)=pizda(1,1)+pizda(2,2)
8497             vv(2)=pizda(2,1)-pizda(1,2)
8498             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8499              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8500              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8501           enddo
8502         enddo
8503       enddo
8504 !d      goto 1112
8505 !d1111  continue
8506       if (l.eq.j+1) then
8507 !d        goto 1110
8508 ! Parallel orientation
8509 ! Contribution from graph III
8510         call transpose2(EUg(1,1,l),auxmat(1,1))
8511         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8512         vv(1)=pizda(1,1)-pizda(2,2)
8513         vv(2)=pizda(1,2)+pizda(2,1)
8514         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8515          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8516 ! Explicit gradient in virtual-dihedral angles.
8517         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8518          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8519          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8520         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8521         vv(1)=pizda(1,1)-pizda(2,2)
8522         vv(2)=pizda(1,2)+pizda(2,1)
8523         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8524          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8525          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8526         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8527         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8528         vv(1)=pizda(1,1)-pizda(2,2)
8529         vv(2)=pizda(1,2)+pizda(2,1)
8530         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8531          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8532          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8533 ! Cartesian gradient
8534         do iii=1,2
8535           do kkk=1,5
8536             do lll=1,3
8537               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8538                 pizda(1,1))
8539               vv(1)=pizda(1,1)-pizda(2,2)
8540               vv(2)=pizda(1,2)+pizda(2,1)
8541               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8542                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8543                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8544             enddo
8545           enddo
8546         enddo
8547 !d        goto 1112
8548 ! Contribution from graph IV
8549 !d1110    continue
8550         call transpose2(EE(1,1,itl),auxmat(1,1))
8551         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8552         vv(1)=pizda(1,1)+pizda(2,2)
8553         vv(2)=pizda(2,1)-pizda(1,2)
8554         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8555          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8556 ! Explicit gradient in virtual-dihedral angles.
8557         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8558          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8559         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8560         vv(1)=pizda(1,1)+pizda(2,2)
8561         vv(2)=pizda(2,1)-pizda(1,2)
8562         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8563          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8564          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8565 ! Cartesian gradient
8566         do iii=1,2
8567           do kkk=1,5
8568             do lll=1,3
8569               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8570                 pizda(1,1))
8571               vv(1)=pizda(1,1)+pizda(2,2)
8572               vv(2)=pizda(2,1)-pizda(1,2)
8573               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8574                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8575                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8576             enddo
8577           enddo
8578         enddo
8579       else
8580 ! Antiparallel orientation
8581 ! Contribution from graph III
8582 !        goto 1110
8583         call transpose2(EUg(1,1,j),auxmat(1,1))
8584         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8585         vv(1)=pizda(1,1)-pizda(2,2)
8586         vv(2)=pizda(1,2)+pizda(2,1)
8587         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8588          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8589 ! Explicit gradient in virtual-dihedral angles.
8590         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8591          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8592          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8593         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8594         vv(1)=pizda(1,1)-pizda(2,2)
8595         vv(2)=pizda(1,2)+pizda(2,1)
8596         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8597          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
8598          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8599         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8600         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8601         vv(1)=pizda(1,1)-pizda(2,2)
8602         vv(2)=pizda(1,2)+pizda(2,1)
8603         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8604          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
8605          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8606 ! Cartesian gradient
8607         do iii=1,2
8608           do kkk=1,5
8609             do lll=1,3
8610               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8611                 pizda(1,1))
8612               vv(1)=pizda(1,1)-pizda(2,2)
8613               vv(2)=pizda(1,2)+pizda(2,1)
8614               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8615                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
8616                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8617             enddo
8618           enddo
8619         enddo
8620 !d        goto 1112
8621 ! Contribution from graph IV
8622 1110    continue
8623         call transpose2(EE(1,1,itj),auxmat(1,1))
8624         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8625         vv(1)=pizda(1,1)+pizda(2,2)
8626         vv(2)=pizda(2,1)-pizda(1,2)
8627         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
8628          -0.5d0*scalar2(vv(1),Ctobr(1,j))
8629 ! Explicit gradient in virtual-dihedral angles.
8630         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8631          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8632         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8633         vv(1)=pizda(1,1)+pizda(2,2)
8634         vv(2)=pizda(2,1)-pizda(1,2)
8635         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8636          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
8637          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8638 ! Cartesian gradient
8639         do iii=1,2
8640           do kkk=1,5
8641             do lll=1,3
8642               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8643                 pizda(1,1))
8644               vv(1)=pizda(1,1)+pizda(2,2)
8645               vv(2)=pizda(2,1)-pizda(1,2)
8646               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8647                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
8648                -0.5d0*scalar2(vv(1),Ctobr(1,j))
8649             enddo
8650           enddo
8651         enddo
8652       endif
8653 1112  continue
8654       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8655 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8656 !d        write (2,*) 'ijkl',i,j,k,l
8657 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8658 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8659 !d      endif
8660 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8661 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8662 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8663 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8664       if (j.lt.nres-1) then
8665         j1=j+1
8666         j2=j-1
8667       else
8668         j1=j-1
8669         j2=j-2
8670       endif
8671       if (l.lt.nres-1) then
8672         l1=l+1
8673         l2=l-1
8674       else
8675         l1=l-1
8676         l2=l-2
8677       endif
8678 !d      eij=1.0d0
8679 !d      ekl=1.0d0
8680 !d      ekont=1.0d0
8681 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8682 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
8683 !        summed up outside the subrouine as for the other subroutines
8684 !        handling long-range interactions. The old code is commented out
8685 !        with "cgrad" to keep track of changes.
8686       do ll=1,3
8687 !grad        ggg1(ll)=eel5*g_contij(ll,1)
8688 !grad        ggg2(ll)=eel5*g_contij(ll,2)
8689         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8690         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8691 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8692 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8693 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8694 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8695 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8696 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8697 !     &   gradcorr5ij,
8698 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8699 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8700 !grad        ghalf=0.5d0*ggg1(ll)
8701 !d        ghalf=0.0d0
8702         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8703         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8704         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8705         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8706         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8707         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8708 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8709 !grad        ghalf=0.5d0*ggg2(ll)
8710         ghalf=0.0d0
8711         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8712         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8713         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8714         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8715         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8716         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8717       enddo
8718 !d      goto 1112
8719 !grad      do m=i+1,j-1
8720 !grad        do ll=1,3
8721 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8722 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8723 !grad        enddo
8724 !grad      enddo
8725 !grad      do m=k+1,l-1
8726 !grad        do ll=1,3
8727 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8728 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8729 !grad        enddo
8730 !grad      enddo
8731 !1112  continue
8732 !grad      do m=i+2,j2
8733 !grad        do ll=1,3
8734 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8735 !grad        enddo
8736 !grad      enddo
8737 !grad      do m=k+2,l2
8738 !grad        do ll=1,3
8739 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8740 !grad        enddo
8741 !grad      enddo
8742 !d      do iii=1,nres-3
8743 !d        write (2,*) iii,g_corr5_loc(iii)
8744 !d      enddo
8745       eello5=ekont*eel5
8746 !d      write (2,*) 'ekont',ekont
8747 !d      write (iout,*) 'eello5',ekont*eel5
8748       return
8749       end function eello5
8750 !-----------------------------------------------------------------------------
8751       real(kind=8) function eello6(i,j,k,l,jj,kk)
8752 !      implicit real*8 (a-h,o-z)
8753 !      include 'DIMENSIONS'
8754 !      include 'COMMON.IOUNITS'
8755 !      include 'COMMON.CHAIN'
8756 !      include 'COMMON.DERIV'
8757 !      include 'COMMON.INTERACT'
8758 !      include 'COMMON.CONTACTS'
8759 !      include 'COMMON.TORSION'
8760 !      include 'COMMON.VAR'
8761 !      include 'COMMON.GEO'
8762 !      include 'COMMON.FFIELD'
8763       real(kind=8),dimension(3) :: ggg1,ggg2
8764       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
8765                    eello6_6,eel6
8766       real(kind=8) :: gradcorr6ij,gradcorr6kl
8767       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8768 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8769 !d        eello6=0.0d0
8770 !d        return
8771 !d      endif
8772 !d      write (iout,*)
8773 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8774 !d     &   ' and',k,l
8775       eello6_1=0.0d0
8776       eello6_2=0.0d0
8777       eello6_3=0.0d0
8778       eello6_4=0.0d0
8779       eello6_5=0.0d0
8780       eello6_6=0.0d0
8781 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8782 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8783       do iii=1,2
8784         do kkk=1,5
8785           do lll=1,3
8786             derx(lll,kkk,iii)=0.0d0
8787           enddo
8788         enddo
8789       enddo
8790 !d      eij=facont_hb(jj,i)
8791 !d      ekl=facont_hb(kk,k)
8792 !d      ekont=eij*ekl
8793 !d      eij=1.0d0
8794 !d      ekl=1.0d0
8795 !d      ekont=1.0d0
8796       if (l.eq.j+1) then
8797         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8798         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8799         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8800         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8801         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8802         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8803       else
8804         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8805         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8806         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8807         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8808         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8809           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8810         else
8811           eello6_5=0.0d0
8812         endif
8813         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8814       endif
8815 ! If turn contributions are considered, they will be handled separately.
8816       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8817 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8818 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8819 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8820 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8821 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8822 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8823 !d      goto 1112
8824       if (j.lt.nres-1) then
8825         j1=j+1
8826         j2=j-1
8827       else
8828         j1=j-1
8829         j2=j-2
8830       endif
8831       if (l.lt.nres-1) then
8832         l1=l+1
8833         l2=l-1
8834       else
8835         l1=l-1
8836         l2=l-2
8837       endif
8838       do ll=1,3
8839 !grad        ggg1(ll)=eel6*g_contij(ll,1)
8840 !grad        ggg2(ll)=eel6*g_contij(ll,2)
8841 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8842 !grad        ghalf=0.5d0*ggg1(ll)
8843 !d        ghalf=0.0d0
8844         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8845         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8846         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8847         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8848         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8849         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8850         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8851         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8852 !grad        ghalf=0.5d0*ggg2(ll)
8853 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8854 !d        ghalf=0.0d0
8855         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8856         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8857         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8858         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8859         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8860         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8861       enddo
8862 !d      goto 1112
8863 !grad      do m=i+1,j-1
8864 !grad        do ll=1,3
8865 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8866 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8867 !grad        enddo
8868 !grad      enddo
8869 !grad      do m=k+1,l-1
8870 !grad        do ll=1,3
8871 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8872 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8873 !grad        enddo
8874 !grad      enddo
8875 !grad1112  continue
8876 !grad      do m=i+2,j2
8877 !grad        do ll=1,3
8878 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8879 !grad        enddo
8880 !grad      enddo
8881 !grad      do m=k+2,l2
8882 !grad        do ll=1,3
8883 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8884 !grad        enddo
8885 !grad      enddo
8886 !d      do iii=1,nres-3
8887 !d        write (2,*) iii,g_corr6_loc(iii)
8888 !d      enddo
8889       eello6=ekont*eel6
8890 !d      write (2,*) 'ekont',ekont
8891 !d      write (iout,*) 'eello6',ekont*eel6
8892       return
8893       end function eello6
8894 !-----------------------------------------------------------------------------
8895       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
8896       use comm_kut
8897 !      implicit real*8 (a-h,o-z)
8898 !      include 'DIMENSIONS'
8899 !      include 'COMMON.IOUNITS'
8900 !      include 'COMMON.CHAIN'
8901 !      include 'COMMON.DERIV'
8902 !      include 'COMMON.INTERACT'
8903 !      include 'COMMON.CONTACTS'
8904 !      include 'COMMON.TORSION'
8905 !      include 'COMMON.VAR'
8906 !      include 'COMMON.GEO'
8907       real(kind=8),dimension(2) :: vv,vv1
8908       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
8909       logical :: swap
8910 !el      logical :: lprn
8911 !el      common /kutas/ lprn
8912       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
8913       real(kind=8) :: s1,s2,s3,s4,s5
8914 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8915 !                                                                              C
8916 !      Parallel       Antiparallel                                             C
8917 !                                                                              C
8918 !          o             o                                                     C
8919 !         /l\           /j\                                                    C
8920 !        /   \         /   \                                                   C
8921 !       /| o |         | o |\                                                  C
8922 !     \ j|/k\|  /   \  |/k\|l /                                                C
8923 !      \ /   \ /     \ /   \ /                                                 C
8924 !       o     o       o     o                                                  C
8925 !       i             i                                                        C
8926 !                                                                              C
8927 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8928       itk=itortyp(itype(k))
8929       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8930       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8931       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8932       call transpose2(EUgC(1,1,k),auxmat(1,1))
8933       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8934       vv1(1)=pizda1(1,1)-pizda1(2,2)
8935       vv1(2)=pizda1(1,2)+pizda1(2,1)
8936       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8937       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8938       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8939       s5=scalar2(vv(1),Dtobr2(1,i))
8940 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8941       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8942       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
8943        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
8944        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
8945        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
8946        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
8947        +scalar2(vv(1),Dtobr2der(1,i)))
8948       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8949       vv1(1)=pizda1(1,1)-pizda1(2,2)
8950       vv1(2)=pizda1(1,2)+pizda1(2,1)
8951       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8952       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8953       if (l.eq.j+1) then
8954         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
8955        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8956        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8957        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8958        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8959       else
8960         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
8961        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8962        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8963        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8964        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8965       endif
8966       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8967       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8968       vv1(1)=pizda1(1,1)-pizda1(2,2)
8969       vv1(2)=pizda1(1,2)+pizda1(2,1)
8970       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
8971        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
8972        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
8973        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8974       do iii=1,2
8975         if (swap) then
8976           ind=3-iii
8977         else
8978           ind=iii
8979         endif
8980         do kkk=1,5
8981           do lll=1,3
8982             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8983             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8984             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8985             call transpose2(EUgC(1,1,k),auxmat(1,1))
8986             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8987               pizda1(1,1))
8988             vv1(1)=pizda1(1,1)-pizda1(2,2)
8989             vv1(2)=pizda1(1,2)+pizda1(2,1)
8990             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8991             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
8992              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8993             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
8994              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8995             s5=scalar2(vv(1),Dtobr2(1,i))
8996             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8997           enddo
8998         enddo
8999       enddo
9000       return
9001       end function eello6_graph1
9002 !-----------------------------------------------------------------------------
9003       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9004       use comm_kut
9005 !      implicit real*8 (a-h,o-z)
9006 !      include 'DIMENSIONS'
9007 !      include 'COMMON.IOUNITS'
9008 !      include 'COMMON.CHAIN'
9009 !      include 'COMMON.DERIV'
9010 !      include 'COMMON.INTERACT'
9011 !      include 'COMMON.CONTACTS'
9012 !      include 'COMMON.TORSION'
9013 !      include 'COMMON.VAR'
9014 !      include 'COMMON.GEO'
9015       logical :: swap
9016       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9017       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9018 !el      logical :: lprn
9019 !el      common /kutas/ lprn
9020       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9021       real(kind=8) :: s2,s3,s4
9022 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9023 !                                                                              C
9024 !      Parallel       Antiparallel                                             C
9025 !                                                                              C
9026 !          o             o                                                     C
9027 !     \   /l\           /j\   /                                                C
9028 !      \ /   \         /   \ /                                                 C
9029 !       o| o |         | o |o                                                  C
9030 !     \ j|/k\|      \  |/k\|l                                                  C
9031 !      \ /   \       \ /   \                                                   C
9032 !       o             o                                                        C
9033 !       i             i                                                        C
9034 !                                                                              C
9035 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9036 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9037 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9038 !           but not in a cluster cumulant
9039 #ifdef MOMENT
9040       s1=dip(1,jj,i)*dip(1,kk,k)
9041 #endif
9042       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9043       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9044       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9045       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9046       call transpose2(EUg(1,1,k),auxmat(1,1))
9047       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9048       vv(1)=pizda(1,1)-pizda(2,2)
9049       vv(2)=pizda(1,2)+pizda(2,1)
9050       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9051 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9052 #ifdef MOMENT
9053       eello6_graph2=-(s1+s2+s3+s4)
9054 #else
9055       eello6_graph2=-(s2+s3+s4)
9056 #endif
9057 !      eello6_graph2=-s3
9058 ! Derivatives in gamma(i-1)
9059       if (i.gt.1) then
9060 #ifdef MOMENT
9061         s1=dipderg(1,jj,i)*dip(1,kk,k)
9062 #endif
9063         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9064         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9065         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9066         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9067 #ifdef MOMENT
9068         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9069 #else
9070         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9071 #endif
9072 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9073       endif
9074 ! Derivatives in gamma(k-1)
9075 #ifdef MOMENT
9076       s1=dip(1,jj,i)*dipderg(1,kk,k)
9077 #endif
9078       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9079       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9080       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9081       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9082       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9083       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9084       vv(1)=pizda(1,1)-pizda(2,2)
9085       vv(2)=pizda(1,2)+pizda(2,1)
9086       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9087 #ifdef MOMENT
9088       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9089 #else
9090       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9091 #endif
9092 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9093 ! Derivatives in gamma(j-1) or gamma(l-1)
9094       if (j.gt.1) then
9095 #ifdef MOMENT
9096         s1=dipderg(3,jj,i)*dip(1,kk,k)
9097 #endif
9098         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9099         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9100         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9101         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9102         vv(1)=pizda(1,1)-pizda(2,2)
9103         vv(2)=pizda(1,2)+pizda(2,1)
9104         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9105 #ifdef MOMENT
9106         if (swap) then
9107           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9108         else
9109           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9110         endif
9111 #endif
9112         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9113 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9114       endif
9115 ! Derivatives in gamma(l-1) or gamma(j-1)
9116       if (l.gt.1) then
9117 #ifdef MOMENT
9118         s1=dip(1,jj,i)*dipderg(3,kk,k)
9119 #endif
9120         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9121         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9122         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9123         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9124         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9125         vv(1)=pizda(1,1)-pizda(2,2)
9126         vv(2)=pizda(1,2)+pizda(2,1)
9127         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9128 #ifdef MOMENT
9129         if (swap) then
9130           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9131         else
9132           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9133         endif
9134 #endif
9135         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9136 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9137       endif
9138 ! Cartesian derivatives.
9139       if (lprn) then
9140         write (2,*) 'In eello6_graph2'
9141         do iii=1,2
9142           write (2,*) 'iii=',iii
9143           do kkk=1,5
9144             write (2,*) 'kkk=',kkk
9145             do jjj=1,2
9146               write (2,'(3(2f10.5),5x)') &
9147               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9148             enddo
9149           enddo
9150         enddo
9151       endif
9152       do iii=1,2
9153         do kkk=1,5
9154           do lll=1,3
9155 #ifdef MOMENT
9156             if (iii.eq.1) then
9157               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9158             else
9159               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9160             endif
9161 #endif
9162             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9163               auxvec(1))
9164             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9165             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9166               auxvec(1))
9167             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9168             call transpose2(EUg(1,1,k),auxmat(1,1))
9169             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9170               pizda(1,1))
9171             vv(1)=pizda(1,1)-pizda(2,2)
9172             vv(2)=pizda(1,2)+pizda(2,1)
9173             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9174 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9175 #ifdef MOMENT
9176             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9177 #else
9178             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9179 #endif
9180             if (swap) then
9181               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9182             else
9183               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9184             endif
9185           enddo
9186         enddo
9187       enddo
9188       return
9189       end function eello6_graph2
9190 !-----------------------------------------------------------------------------
9191       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9192 !      implicit real*8 (a-h,o-z)
9193 !      include 'DIMENSIONS'
9194 !      include 'COMMON.IOUNITS'
9195 !      include 'COMMON.CHAIN'
9196 !      include 'COMMON.DERIV'
9197 !      include 'COMMON.INTERACT'
9198 !      include 'COMMON.CONTACTS'
9199 !      include 'COMMON.TORSION'
9200 !      include 'COMMON.VAR'
9201 !      include 'COMMON.GEO'
9202       real(kind=8),dimension(2) :: vv,auxvec
9203       real(kind=8),dimension(2,2) :: pizda,auxmat
9204       logical :: swap
9205       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9206       real(kind=8) :: s1,s2,s3,s4
9207 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9208 !                                                                              C
9209 !      Parallel       Antiparallel                                             C
9210 !                                                                              C
9211 !          o             o                                                     C
9212 !         /l\   /   \   /j\                                                    C
9213 !        /   \ /     \ /   \                                                   C
9214 !       /| o |o       o| o |\                                                  C
9215 !       j|/k\|  /      |/k\|l /                                                C
9216 !        /   \ /       /   \ /                                                 C
9217 !       /     o       /     o                                                  C
9218 !       i             i                                                        C
9219 !                                                                              C
9220 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9221 !
9222 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9223 !           energy moment and not to the cluster cumulant.
9224       iti=itortyp(itype(i))
9225       if (j.lt.nres-1) then
9226         itj1=itortyp(itype(j+1))
9227       else
9228         itj1=ntortyp+1
9229       endif
9230       itk=itortyp(itype(k))
9231       itk1=itortyp(itype(k+1))
9232       if (l.lt.nres-1) then
9233         itl1=itortyp(itype(l+1))
9234       else
9235         itl1=ntortyp+1
9236       endif
9237 #ifdef MOMENT
9238       s1=dip(4,jj,i)*dip(4,kk,k)
9239 #endif
9240       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9241       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9242       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9243       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9244       call transpose2(EE(1,1,itk),auxmat(1,1))
9245       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9246       vv(1)=pizda(1,1)+pizda(2,2)
9247       vv(2)=pizda(2,1)-pizda(1,2)
9248       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9249 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9250 !d     & "sum",-(s2+s3+s4)
9251 #ifdef MOMENT
9252       eello6_graph3=-(s1+s2+s3+s4)
9253 #else
9254       eello6_graph3=-(s2+s3+s4)
9255 #endif
9256 !      eello6_graph3=-s4
9257 ! Derivatives in gamma(k-1)
9258       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9259       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9260       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9261       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9262 ! Derivatives in gamma(l-1)
9263       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9264       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9265       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9266       vv(1)=pizda(1,1)+pizda(2,2)
9267       vv(2)=pizda(2,1)-pizda(1,2)
9268       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9269       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9270 ! Cartesian derivatives.
9271       do iii=1,2
9272         do kkk=1,5
9273           do lll=1,3
9274 #ifdef MOMENT
9275             if (iii.eq.1) then
9276               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9277             else
9278               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9279             endif
9280 #endif
9281             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9282               auxvec(1))
9283             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9284             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9285               auxvec(1))
9286             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9287             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9288               pizda(1,1))
9289             vv(1)=pizda(1,1)+pizda(2,2)
9290             vv(2)=pizda(2,1)-pizda(1,2)
9291             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9292 #ifdef MOMENT
9293             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9294 #else
9295             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9296 #endif
9297             if (swap) then
9298               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9299             else
9300               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9301             endif
9302 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9303           enddo
9304         enddo
9305       enddo
9306       return
9307       end function eello6_graph3
9308 !-----------------------------------------------------------------------------
9309       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9310 !      implicit real*8 (a-h,o-z)
9311 !      include 'DIMENSIONS'
9312 !      include 'COMMON.IOUNITS'
9313 !      include 'COMMON.CHAIN'
9314 !      include 'COMMON.DERIV'
9315 !      include 'COMMON.INTERACT'
9316 !      include 'COMMON.CONTACTS'
9317 !      include 'COMMON.TORSION'
9318 !      include 'COMMON.VAR'
9319 !      include 'COMMON.GEO'
9320 !      include 'COMMON.FFIELD'
9321       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9322       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9323       logical :: swap
9324       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9325               iii,kkk,lll
9326       real(kind=8) :: s1,s2,s3,s4
9327 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9328 !                                                                              C
9329 !      Parallel       Antiparallel                                             C
9330 !                                                                              C
9331 !          o             o                                                     C
9332 !         /l\   /   \   /j\                                                    C
9333 !        /   \ /     \ /   \                                                   C
9334 !       /| o |o       o| o |\                                                  C
9335 !     \ j|/k\|      \  |/k\|l                                                  C
9336 !      \ /   \       \ /   \                                                   C
9337 !       o     \       o     \                                                  C
9338 !       i             i                                                        C
9339 !                                                                              C
9340 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9341 !
9342 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9343 !           energy moment and not to the cluster cumulant.
9344 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9345       iti=itortyp(itype(i))
9346       itj=itortyp(itype(j))
9347       if (j.lt.nres-1) then
9348         itj1=itortyp(itype(j+1))
9349       else
9350         itj1=ntortyp+1
9351       endif
9352       itk=itortyp(itype(k))
9353       if (k.lt.nres-1) then
9354         itk1=itortyp(itype(k+1))
9355       else
9356         itk1=ntortyp+1
9357       endif
9358       itl=itortyp(itype(l))
9359       if (l.lt.nres-1) then
9360         itl1=itortyp(itype(l+1))
9361       else
9362         itl1=ntortyp+1
9363       endif
9364 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9365 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9366 !d     & ' itl',itl,' itl1',itl1
9367 #ifdef MOMENT
9368       if (imat.eq.1) then
9369         s1=dip(3,jj,i)*dip(3,kk,k)
9370       else
9371         s1=dip(2,jj,j)*dip(2,kk,l)
9372       endif
9373 #endif
9374       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9375       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9376       if (j.eq.l+1) then
9377         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9378         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9379       else
9380         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9381         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9382       endif
9383       call transpose2(EUg(1,1,k),auxmat(1,1))
9384       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9385       vv(1)=pizda(1,1)-pizda(2,2)
9386       vv(2)=pizda(2,1)+pizda(1,2)
9387       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9388 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9389 #ifdef MOMENT
9390       eello6_graph4=-(s1+s2+s3+s4)
9391 #else
9392       eello6_graph4=-(s2+s3+s4)
9393 #endif
9394 ! Derivatives in gamma(i-1)
9395       if (i.gt.1) then
9396 #ifdef MOMENT
9397         if (imat.eq.1) then
9398           s1=dipderg(2,jj,i)*dip(3,kk,k)
9399         else
9400           s1=dipderg(4,jj,j)*dip(2,kk,l)
9401         endif
9402 #endif
9403         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9404         if (j.eq.l+1) then
9405           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9406           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9407         else
9408           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9409           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9410         endif
9411         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9412         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9413 !d          write (2,*) 'turn6 derivatives'
9414 #ifdef MOMENT
9415           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9416 #else
9417           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9418 #endif
9419         else
9420 #ifdef MOMENT
9421           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9422 #else
9423           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9424 #endif
9425         endif
9426       endif
9427 ! Derivatives in gamma(k-1)
9428 #ifdef MOMENT
9429       if (imat.eq.1) then
9430         s1=dip(3,jj,i)*dipderg(2,kk,k)
9431       else
9432         s1=dip(2,jj,j)*dipderg(4,kk,l)
9433       endif
9434 #endif
9435       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9436       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9437       if (j.eq.l+1) then
9438         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9439         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9440       else
9441         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9442         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9443       endif
9444       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9445       call matmat2(AECA(1,1,imat),auxmat1(1,1),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),Dtobr2(1,i))
9449       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9450 #ifdef MOMENT
9451         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9452 #else
9453         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9454 #endif
9455       else
9456 #ifdef MOMENT
9457         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9458 #else
9459         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9460 #endif
9461       endif
9462 ! Derivatives in gamma(j-1) or gamma(l-1)
9463       if (l.eq.j+1 .and. l.gt.1) then
9464         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9465         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9466         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9467         vv(1)=pizda(1,1)-pizda(2,2)
9468         vv(2)=pizda(2,1)+pizda(1,2)
9469         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9470         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9471       else if (j.gt.1) then
9472         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9473         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9474         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9475         vv(1)=pizda(1,1)-pizda(2,2)
9476         vv(2)=pizda(2,1)+pizda(1,2)
9477         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9478         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9479           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9480         else
9481           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9482         endif
9483       endif
9484 ! Cartesian derivatives.
9485       do iii=1,2
9486         do kkk=1,5
9487           do lll=1,3
9488 #ifdef MOMENT
9489             if (iii.eq.1) then
9490               if (imat.eq.1) then
9491                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9492               else
9493                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9494               endif
9495             else
9496               if (imat.eq.1) then
9497                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9498               else
9499                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9500               endif
9501             endif
9502 #endif
9503             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9504               auxvec(1))
9505             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9506             if (j.eq.l+1) then
9507               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9508                 b1(1,itj1),auxvec(1))
9509               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9510             else
9511               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9512                 b1(1,itl1),auxvec(1))
9513               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9514             endif
9515             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9516               pizda(1,1))
9517             vv(1)=pizda(1,1)-pizda(2,2)
9518             vv(2)=pizda(2,1)+pizda(1,2)
9519             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9520             if (swap) then
9521               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9522 #ifdef MOMENT
9523                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9524                    -(s1+s2+s4)
9525 #else
9526                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9527                    -(s2+s4)
9528 #endif
9529                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9530               else
9531 #ifdef MOMENT
9532                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9533 #else
9534                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9535 #endif
9536                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9537               endif
9538             else
9539 #ifdef MOMENT
9540               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9541 #else
9542               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9543 #endif
9544               if (l.eq.j+1) then
9545                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9546               else
9547                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9548               endif
9549             endif
9550           enddo
9551         enddo
9552       enddo
9553       return
9554       end function eello6_graph4
9555 !-----------------------------------------------------------------------------
9556       real(kind=8) function eello_turn6(i,jj,kk)
9557 !      implicit real*8 (a-h,o-z)
9558 !      include 'DIMENSIONS'
9559 !      include 'COMMON.IOUNITS'
9560 !      include 'COMMON.CHAIN'
9561 !      include 'COMMON.DERIV'
9562 !      include 'COMMON.INTERACT'
9563 !      include 'COMMON.CONTACTS'
9564 !      include 'COMMON.TORSION'
9565 !      include 'COMMON.VAR'
9566 !      include 'COMMON.GEO'
9567       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9568       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9569       real(kind=8),dimension(3) :: ggg1,ggg2
9570       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9571       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9572 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9573 !           the respective energy moment and not to the cluster cumulant.
9574 !el local variables
9575       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9576       integer :: j1,j2,l1,l2,ll
9577       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9578       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9579       s1=0.0d0
9580       s8=0.0d0
9581       s13=0.0d0
9582 !
9583       eello_turn6=0.0d0
9584       j=i+4
9585       k=i+1
9586       l=i+3
9587       iti=itortyp(itype(i))
9588       itk=itortyp(itype(k))
9589       itk1=itortyp(itype(k+1))
9590       itl=itortyp(itype(l))
9591       itj=itortyp(itype(j))
9592 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9593 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
9594 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9595 !d        eello6=0.0d0
9596 !d        return
9597 !d      endif
9598 !d      write (iout,*)
9599 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9600 !d     &   ' and',k,l
9601 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
9602       do iii=1,2
9603         do kkk=1,5
9604           do lll=1,3
9605             derx_turn(lll,kkk,iii)=0.0d0
9606           enddo
9607         enddo
9608       enddo
9609 !d      eij=1.0d0
9610 !d      ekl=1.0d0
9611 !d      ekont=1.0d0
9612       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9613 !d      eello6_5=0.0d0
9614 !d      write (2,*) 'eello6_5',eello6_5
9615 #ifdef MOMENT
9616       call transpose2(AEA(1,1,1),auxmat(1,1))
9617       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9618       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9619       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9620 #endif
9621       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9622       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9623       s2 = scalar2(b1(1,itk),vtemp1(1))
9624 #ifdef MOMENT
9625       call transpose2(AEA(1,1,2),atemp(1,1))
9626       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9627       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9628       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9629 #endif
9630       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9631       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9632       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9633 #ifdef MOMENT
9634       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9635       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9636       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9637       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9638       ss13 = scalar2(b1(1,itk),vtemp4(1))
9639       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9640 #endif
9641 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9642 !      s1=0.0d0
9643 !      s2=0.0d0
9644 !      s8=0.0d0
9645 !      s12=0.0d0
9646 !      s13=0.0d0
9647       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9648 ! Derivatives in gamma(i+2)
9649       s1d =0.0d0
9650       s8d =0.0d0
9651 #ifdef MOMENT
9652       call transpose2(AEA(1,1,1),auxmatd(1,1))
9653       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9654       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9655       call transpose2(AEAderg(1,1,2),atempd(1,1))
9656       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9657       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9658 #endif
9659       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9660       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9661       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9662 !      s1d=0.0d0
9663 !      s2d=0.0d0
9664 !      s8d=0.0d0
9665 !      s12d=0.0d0
9666 !      s13d=0.0d0
9667       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9668 ! Derivatives in gamma(i+3)
9669 #ifdef MOMENT
9670       call transpose2(AEA(1,1,1),auxmatd(1,1))
9671       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9672       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9673       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9674 #endif
9675       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9676       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9677       s2d = scalar2(b1(1,itk),vtemp1d(1))
9678 #ifdef MOMENT
9679       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9680       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9681 #endif
9682       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9683 #ifdef MOMENT
9684       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9685       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9686       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9687 #endif
9688 !      s1d=0.0d0
9689 !      s2d=0.0d0
9690 !      s8d=0.0d0
9691 !      s12d=0.0d0
9692 !      s13d=0.0d0
9693 #ifdef MOMENT
9694       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9695                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9696 #else
9697       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9698                     -0.5d0*ekont*(s2d+s12d)
9699 #endif
9700 ! Derivatives in gamma(i+4)
9701       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9702       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9703       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9704 #ifdef MOMENT
9705       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9706       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9707       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9708 #endif
9709 !      s1d=0.0d0
9710 !      s2d=0.0d0
9711 !      s8d=0.0d0
9712 !      s12d=0.0d0
9713 !      s13d=0.0d0
9714 #ifdef MOMENT
9715       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9716 #else
9717       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9718 #endif
9719 ! Derivatives in gamma(i+5)
9720 #ifdef MOMENT
9721       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9722       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9723       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9724 #endif
9725       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9726       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9727       s2d = scalar2(b1(1,itk),vtemp1d(1))
9728 #ifdef MOMENT
9729       call transpose2(AEA(1,1,2),atempd(1,1))
9730       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9731       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9732 #endif
9733       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9734       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9735 #ifdef MOMENT
9736       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9737       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9738       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9739 #endif
9740 !      s1d=0.0d0
9741 !      s2d=0.0d0
9742 !      s8d=0.0d0
9743 !      s12d=0.0d0
9744 !      s13d=0.0d0
9745 #ifdef MOMENT
9746       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9747                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9748 #else
9749       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9750                     -0.5d0*ekont*(s2d+s12d)
9751 #endif
9752 ! Cartesian derivatives
9753       do iii=1,2
9754         do kkk=1,5
9755           do lll=1,3
9756 #ifdef MOMENT
9757             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9758             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9759             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9760 #endif
9761             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9762             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
9763                 vtemp1d(1))
9764             s2d = scalar2(b1(1,itk),vtemp1d(1))
9765 #ifdef MOMENT
9766             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9767             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9768             s8d = -(atempd(1,1)+atempd(2,2))* &
9769                  scalar2(cc(1,1,itl),vtemp2(1))
9770 #endif
9771             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
9772                  auxmatd(1,1))
9773             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9774             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9775 !      s1d=0.0d0
9776 !      s2d=0.0d0
9777 !      s8d=0.0d0
9778 !      s12d=0.0d0
9779 !      s13d=0.0d0
9780 #ifdef MOMENT
9781             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9782               - 0.5d0*(s1d+s2d)
9783 #else
9784             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9785               - 0.5d0*s2d
9786 #endif
9787 #ifdef MOMENT
9788             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9789               - 0.5d0*(s8d+s12d)
9790 #else
9791             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9792               - 0.5d0*s12d
9793 #endif
9794           enddo
9795         enddo
9796       enddo
9797 #ifdef MOMENT
9798       do kkk=1,5
9799         do lll=1,3
9800           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
9801             achuj_tempd(1,1))
9802           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9803           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9804           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9805           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9806           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
9807             vtemp4d(1))
9808           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9809           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9810           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9811         enddo
9812       enddo
9813 #endif
9814 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9815 !d     &  16*eel_turn6_num
9816 !d      goto 1112
9817       if (j.lt.nres-1) then
9818         j1=j+1
9819         j2=j-1
9820       else
9821         j1=j-1
9822         j2=j-2
9823       endif
9824       if (l.lt.nres-1) then
9825         l1=l+1
9826         l2=l-1
9827       else
9828         l1=l-1
9829         l2=l-2
9830       endif
9831       do ll=1,3
9832 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9833 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9834 !grad        ghalf=0.5d0*ggg1(ll)
9835 !d        ghalf=0.0d0
9836         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9837         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9838         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
9839           +ekont*derx_turn(ll,2,1)
9840         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9841         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
9842           +ekont*derx_turn(ll,4,1)
9843         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9844         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9845         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9846 !grad        ghalf=0.5d0*ggg2(ll)
9847 !d        ghalf=0.0d0
9848         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
9849           +ekont*derx_turn(ll,2,2)
9850         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9851         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
9852           +ekont*derx_turn(ll,4,2)
9853         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9854         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9855         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9856       enddo
9857 !d      goto 1112
9858 !grad      do m=i+1,j-1
9859 !grad        do ll=1,3
9860 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9861 !grad        enddo
9862 !grad      enddo
9863 !grad      do m=k+1,l-1
9864 !grad        do ll=1,3
9865 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9866 !grad        enddo
9867 !grad      enddo
9868 !grad1112  continue
9869 !grad      do m=i+2,j2
9870 !grad        do ll=1,3
9871 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9872 !grad        enddo
9873 !grad      enddo
9874 !grad      do m=k+2,l2
9875 !grad        do ll=1,3
9876 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9877 !grad        enddo
9878 !grad      enddo
9879 !d      do iii=1,nres-3
9880 !d        write (2,*) iii,g_corr6_loc(iii)
9881 !d      enddo
9882       eello_turn6=ekont*eel_turn6
9883 !d      write (2,*) 'ekont',ekont
9884 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
9885       return
9886       end function eello_turn6
9887 !-----------------------------------------------------------------------------
9888       subroutine MATVEC2(A1,V1,V2)
9889 !DIR$ INLINEALWAYS MATVEC2
9890 #ifndef OSF
9891 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9892 #endif
9893 !      implicit real*8 (a-h,o-z)
9894 !      include 'DIMENSIONS'
9895       real(kind=8),dimension(2) :: V1,V2
9896       real(kind=8),dimension(2,2) :: A1
9897       real(kind=8) :: vaux1,vaux2
9898 !      DO 1 I=1,2
9899 !        VI=0.0
9900 !        DO 3 K=1,2
9901 !    3     VI=VI+A1(I,K)*V1(K)
9902 !        Vaux(I)=VI
9903 !    1 CONTINUE
9904
9905       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9906       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9907
9908       v2(1)=vaux1
9909       v2(2)=vaux2
9910       end subroutine MATVEC2
9911 !-----------------------------------------------------------------------------
9912       subroutine MATMAT2(A1,A2,A3)
9913 #ifndef OSF
9914 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9915 #endif
9916 !      implicit real*8 (a-h,o-z)
9917 !      include 'DIMENSIONS'
9918       real(kind=8),dimension(2,2) :: A1,A2,A3
9919       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
9920 !      DIMENSION AI3(2,2)
9921 !        DO  J=1,2
9922 !          A3IJ=0.0
9923 !          DO K=1,2
9924 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9925 !          enddo
9926 !          A3(I,J)=A3IJ
9927 !       enddo
9928 !      enddo
9929
9930       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9931       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9932       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9933       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9934
9935       A3(1,1)=AI3_11
9936       A3(2,1)=AI3_21
9937       A3(1,2)=AI3_12
9938       A3(2,2)=AI3_22
9939       end subroutine MATMAT2
9940 !-----------------------------------------------------------------------------
9941       real(kind=8) function scalar2(u,v)
9942 !DIR$ INLINEALWAYS scalar2
9943       implicit none
9944       real(kind=8),dimension(2) :: u,v
9945       real(kind=8) :: sc
9946       integer :: i
9947       scalar2=u(1)*v(1)+u(2)*v(2)
9948       return
9949       end function scalar2
9950 !-----------------------------------------------------------------------------
9951       subroutine transpose2(a,at)
9952 !DIR$ INLINEALWAYS transpose2
9953 #ifndef OSF
9954 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
9955 #endif
9956       implicit none
9957       real(kind=8),dimension(2,2) :: a,at
9958       at(1,1)=a(1,1)
9959       at(1,2)=a(2,1)
9960       at(2,1)=a(1,2)
9961       at(2,2)=a(2,2)
9962       return
9963       end subroutine transpose2
9964 !-----------------------------------------------------------------------------
9965       subroutine transpose(n,a,at)
9966       implicit none
9967       integer :: n,i,j
9968       real(kind=8),dimension(n,n) :: a,at
9969       do i=1,n
9970         do j=1,n
9971           at(j,i)=a(i,j)
9972         enddo
9973       enddo
9974       return
9975       end subroutine transpose
9976 !-----------------------------------------------------------------------------
9977       subroutine prodmat3(a1,a2,kk,transp,prod)
9978 !DIR$ INLINEALWAYS prodmat3
9979 #ifndef OSF
9980 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
9981 #endif
9982       implicit none
9983       integer :: i,j
9984       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
9985       logical :: transp
9986 !rc      double precision auxmat(2,2),prod_(2,2)
9987
9988       if (transp) then
9989 !rc        call transpose2(kk(1,1),auxmat(1,1))
9990 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9991 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9992
9993            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
9994        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9995            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
9996        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9997            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
9998        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9999            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10000        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10001
10002       else
10003 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10004 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10005
10006            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10007         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10008            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10009         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10010            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10011         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10012            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10013         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10014
10015       endif
10016 !      call transpose2(a2(1,1),a2t(1,1))
10017
10018 !rc      print *,transp
10019 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10020 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10021
10022       return
10023       end subroutine prodmat3
10024 !-----------------------------------------------------------------------------
10025 ! energy_p_new_barrier.F
10026 !-----------------------------------------------------------------------------
10027       subroutine sum_gradient
10028 !      implicit real*8 (a-h,o-z)
10029       use io_base, only: pdbout
10030 !      include 'DIMENSIONS'
10031 #ifndef ISNAN
10032       external proc_proc
10033 #ifdef WINPGI
10034 !MS$ATTRIBUTES C ::  proc_proc
10035 #endif
10036 #endif
10037 #ifdef MPI
10038       include 'mpif.h'
10039 #endif
10040       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10041                    gloc_scbuf !(3,maxres)
10042
10043       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10044 !#endif
10045 !el local variables
10046       integer :: i,j,k,ierror,ierr
10047       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10048                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10049                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10050                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10051                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10052                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10053                    gsccorr_max,gsccorrx_max,time00
10054
10055 !      include 'COMMON.SETUP'
10056 !      include 'COMMON.IOUNITS'
10057 !      include 'COMMON.FFIELD'
10058 !      include 'COMMON.DERIV'
10059 !      include 'COMMON.INTERACT'
10060 !      include 'COMMON.SBRIDGE'
10061 !      include 'COMMON.CHAIN'
10062 !      include 'COMMON.VAR'
10063 !      include 'COMMON.CONTROL'
10064 !      include 'COMMON.TIME1'
10065 !      include 'COMMON.MAXGRAD'
10066 !      include 'COMMON.SCCOR'
10067 #ifdef TIMING
10068       time01=MPI_Wtime()
10069 #endif
10070 #ifdef DEBUG
10071       write (iout,*) "sum_gradient gvdwc, gvdwx"
10072       do i=1,nres
10073         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10074          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10075       enddo
10076       call flush(iout)
10077 #endif
10078 #ifdef MPI
10079         gradbufc=0.0d0
10080         gradbufx=0.0d0
10081         gradbufc_sum=0.0d0
10082         gloc_scbuf=0.0d0
10083         glocbuf=0.0d0
10084 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10085         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10086           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10087 #endif
10088 !
10089 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10090 !            in virtual-bond-vector coordinates
10091 !
10092 #ifdef DEBUG
10093 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10094 !      do i=1,nres-1
10095 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10096 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10097 !      enddo
10098 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10099 !      do i=1,nres-1
10100 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10101 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10102 !      enddo
10103       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10104       do i=1,nres
10105         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10106          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10107          (gvdwc_scpp(j,i),j=1,3)
10108       enddo
10109       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10110       do i=1,nres
10111         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10112          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10113          (gelc_loc_long(j,i),j=1,3)
10114       enddo
10115       call flush(iout)
10116 #endif
10117 #ifdef SPLITELE
10118       do i=0,nct
10119         do j=1,3
10120           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10121                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10122                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10123                       wel_loc*gel_loc_long(j,i)+ &
10124                       wcorr*gradcorr_long(j,i)+ &
10125                       wcorr5*gradcorr5_long(j,i)+ &
10126                       wcorr6*gradcorr6_long(j,i)+ &
10127                       wturn6*gcorr6_turn_long(j,i)+ &
10128                       wstrain*ghpbc(j,i) &
10129                      +wliptran*gliptranc(j,i) &
10130                      +welec*gshieldc(j,i) &
10131                      +wcorr*gshieldc_ec(j,i) &
10132                      +wturn3*gshieldc_t3(j,i)&
10133                      +wturn4*gshieldc_t4(j,i)&
10134                      +wel_loc*gshieldc_ll(j,i)
10135
10136
10137         enddo
10138       enddo
10139 #else
10140       do i=0,nct
10141         do j=1,3
10142           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10143                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10144                       welec*gelc_long(j,i)+ &
10145                       wbond*gradb(j,i)+ &
10146                       wel_loc*gel_loc_long(j,i)+ &
10147                       wcorr*gradcorr_long(j,i)+ &
10148                       wcorr5*gradcorr5_long(j,i)+ &
10149                       wcorr6*gradcorr6_long(j,i)+ &
10150                       wturn6*gcorr6_turn_long(j,i)+ &
10151                       wstrain*ghpbc(j,i) &
10152                      +wliptran*gliptranc(j,i) &
10153                      +welec*gshieldc(j,i)&
10154                      +wcorr*gshieldc_ec(j,i) &
10155                      +wturn4*gshieldc_t4(j,i) &
10156                      +wel_loc*gshieldc_ll(j,i)
10157
10158
10159         enddo
10160       enddo
10161 #endif
10162 #ifdef MPI
10163       if (nfgtasks.gt.1) then
10164       time00=MPI_Wtime()
10165 #ifdef DEBUG
10166       write (iout,*) "gradbufc before allreduce"
10167       do i=1,nres
10168         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10169       enddo
10170       call flush(iout)
10171 #endif
10172       do i=0,nres
10173         do j=1,3
10174           gradbufc_sum(j,i)=gradbufc(j,i)
10175         enddo
10176       enddo
10177 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10178 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10179 !      time_reduce=time_reduce+MPI_Wtime()-time00
10180 #ifdef DEBUG
10181 !      write (iout,*) "gradbufc_sum after allreduce"
10182 !      do i=1,nres
10183 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10184 !      enddo
10185 !      call flush(iout)
10186 #endif
10187 #ifdef TIMING
10188 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10189 #endif
10190       do i=0,nres
10191         do k=1,3
10192           gradbufc(k,i)=0.0d0
10193         enddo
10194       enddo
10195 #ifdef DEBUG
10196       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10197       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10198                         " jgrad_end  ",jgrad_end(i),&
10199                         i=igrad_start,igrad_end)
10200 #endif
10201 !
10202 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10203 ! do not parallelize this part.
10204 !
10205 !      do i=igrad_start,igrad_end
10206 !        do j=jgrad_start(i),jgrad_end(i)
10207 !          do k=1,3
10208 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10209 !          enddo
10210 !        enddo
10211 !      enddo
10212       do j=1,3
10213         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10214       enddo
10215       do i=nres-2,-1,-1
10216         do j=1,3
10217           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10218         enddo
10219       enddo
10220 #ifdef DEBUG
10221       write (iout,*) "gradbufc after summing"
10222       do i=1,nres
10223         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10224       enddo
10225       call flush(iout)
10226 #endif
10227       else
10228 #endif
10229 !el#define DEBUG
10230 #ifdef DEBUG
10231       write (iout,*) "gradbufc"
10232       do i=1,nres
10233         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10234       enddo
10235       call flush(iout)
10236 #endif
10237 !el#undef DEBUG
10238       do i=-1,nres
10239         do j=1,3
10240           gradbufc_sum(j,i)=gradbufc(j,i)
10241           gradbufc(j,i)=0.0d0
10242         enddo
10243       enddo
10244       do j=1,3
10245         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10246       enddo
10247       do i=nres-2,-1,-1
10248         do j=1,3
10249           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10250         enddo
10251       enddo
10252 !      do i=nnt,nres-1
10253 !        do k=1,3
10254 !          gradbufc(k,i)=0.0d0
10255 !        enddo
10256 !        do j=i+1,nres
10257 !          do k=1,3
10258 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10259 !          enddo
10260 !        enddo
10261 !      enddo
10262 !el#define DEBUG
10263 #ifdef DEBUG
10264       write (iout,*) "gradbufc after summing"
10265       do i=1,nres
10266         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10267       enddo
10268       call flush(iout)
10269 #endif
10270 !el#undef DEBUG
10271 #ifdef MPI
10272       endif
10273 #endif
10274       do k=1,3
10275         gradbufc(k,nres)=0.0d0
10276       enddo
10277 !el----------------
10278 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10279 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10280 !el-----------------
10281       do i=-1,nct
10282         do j=1,3
10283 #ifdef SPLITELE
10284           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10285                       wel_loc*gel_loc(j,i)+ &
10286                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10287                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10288                       wel_loc*gel_loc_long(j,i)+ &
10289                       wcorr*gradcorr_long(j,i)+ &
10290                       wcorr5*gradcorr5_long(j,i)+ &
10291                       wcorr6*gradcorr6_long(j,i)+ &
10292                       wturn6*gcorr6_turn_long(j,i))+ &
10293                       wbond*gradb(j,i)+ &
10294                       wcorr*gradcorr(j,i)+ &
10295                       wturn3*gcorr3_turn(j,i)+ &
10296                       wturn4*gcorr4_turn(j,i)+ &
10297                       wcorr5*gradcorr5(j,i)+ &
10298                       wcorr6*gradcorr6(j,i)+ &
10299                       wturn6*gcorr6_turn(j,i)+ &
10300                       wsccor*gsccorc(j,i) &
10301                      +wscloc*gscloc(j,i)  &
10302                      +wliptran*gliptranc(j,i) &
10303                      +welec*gshieldc(j,i) &
10304                      +welec*gshieldc_loc(j,i) &
10305                      +wcorr*gshieldc_ec(j,i) &
10306                      +wcorr*gshieldc_loc_ec(j,i) &
10307                      +wturn3*gshieldc_t3(j,i) &
10308                      +wturn3*gshieldc_loc_t3(j,i) &
10309                      +wturn4*gshieldc_t4(j,i) &
10310                      +wturn4*gshieldc_loc_t4(j,i) &
10311                      +wel_loc*gshieldc_ll(j,i) &
10312                      +wel_loc*gshieldc_loc_ll(j,i)
10313
10314 #else
10315           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10316                       wel_loc*gel_loc(j,i)+ &
10317                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10318                       welec*gelc_long(j,i)+ &
10319                       wel_loc*gel_loc_long(j,i)+ &
10320 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10321                       wcorr5*gradcorr5_long(j,i)+ &
10322                       wcorr6*gradcorr6_long(j,i)+ &
10323                       wturn6*gcorr6_turn_long(j,i))+ &
10324                       wbond*gradb(j,i)+ &
10325                       wcorr*gradcorr(j,i)+ &
10326                       wturn3*gcorr3_turn(j,i)+ &
10327                       wturn4*gcorr4_turn(j,i)+ &
10328                       wcorr5*gradcorr5(j,i)+ &
10329                       wcorr6*gradcorr6(j,i)+ &
10330                       wturn6*gcorr6_turn(j,i)+ &
10331                       wsccor*gsccorc(j,i) &
10332                      +wscloc*gscloc(j,i) &
10333                      +wliptran*gliptranc(j,i) &
10334                      +welec*gshieldc(j,i) &
10335                      +welec*gshieldc_loc(j,) &
10336                      +wcorr*gshieldc_ec(j,i) &
10337                      +wcorr*gshieldc_loc_ec(j,i) &
10338                      +wturn3*gshieldc_t3(j,i) &
10339                      +wturn3*gshieldc_loc_t3(j,i) &
10340                      +wturn4*gshieldc_t4(j,i) &
10341                      +wturn4*gshieldc_loc_t4(j,i) &
10342                      +wel_loc*gshieldc_ll(j,i) &
10343                      +wel_loc*gshieldc_loc_ll(j,i)
10344
10345
10346 #endif
10347           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10348                         wbond*gradbx(j,i)+ &
10349                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10350                         wsccor*gsccorx(j,i) &
10351                        +wscloc*gsclocx(j,i) &
10352                        +wliptran*gliptranx(j,i) &
10353                        +welec*gshieldx(j,i)     &
10354                        +wcorr*gshieldx_ec(j,i)  &
10355                        +wturn3*gshieldx_t3(j,i) &
10356                        +wturn4*gshieldx_t4(j,i) &
10357                        +wel_loc*gshieldx_ll(j,i)
10358
10359         enddo
10360       enddo
10361 #ifdef DEBUG
10362       write (iout,*) "gloc before adding corr"
10363       do i=1,4*nres
10364         write (iout,*) i,gloc(i,icg)
10365       enddo
10366 #endif
10367       do i=1,nres-3
10368         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10369          +wcorr5*g_corr5_loc(i) &
10370          +wcorr6*g_corr6_loc(i) &
10371          +wturn4*gel_loc_turn4(i) &
10372          +wturn3*gel_loc_turn3(i) &
10373          +wturn6*gel_loc_turn6(i) &
10374          +wel_loc*gel_loc_loc(i)
10375       enddo
10376 #ifdef DEBUG
10377       write (iout,*) "gloc after adding corr"
10378       do i=1,4*nres
10379         write (iout,*) i,gloc(i,icg)
10380       enddo
10381 #endif
10382 #ifdef MPI
10383       if (nfgtasks.gt.1) then
10384         do j=1,3
10385           do i=1,nres
10386             gradbufc(j,i)=gradc(j,i,icg)
10387             gradbufx(j,i)=gradx(j,i,icg)
10388           enddo
10389         enddo
10390         do i=1,4*nres
10391           glocbuf(i)=gloc(i,icg)
10392         enddo
10393 !#define DEBUG
10394 #ifdef DEBUG
10395       write (iout,*) "gloc_sc before reduce"
10396       do i=1,nres
10397        do j=1,1
10398         write (iout,*) i,j,gloc_sc(j,i,icg)
10399        enddo
10400       enddo
10401 #endif
10402 !#undef DEBUG
10403         do i=1,nres
10404          do j=1,3
10405           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10406          enddo
10407         enddo
10408         time00=MPI_Wtime()
10409         call MPI_Barrier(FG_COMM,IERR)
10410         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10411         time00=MPI_Wtime()
10412         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10413           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10414         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
10415           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10416         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10417           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10418         time_reduce=time_reduce+MPI_Wtime()-time00
10419         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10420           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10421         time_reduce=time_reduce+MPI_Wtime()-time00
10422 !#define DEBUG
10423 #ifdef DEBUG
10424       write (iout,*) "gloc_sc after reduce"
10425       do i=1,nres
10426        do j=1,1
10427         write (iout,*) i,j,gloc_sc(j,i,icg)
10428        enddo
10429       enddo
10430 #endif
10431 !#undef DEBUG
10432 #ifdef DEBUG
10433       write (iout,*) "gloc after reduce"
10434       do i=1,4*nres
10435         write (iout,*) i,gloc(i,icg)
10436       enddo
10437 #endif
10438       endif
10439 #endif
10440       if (gnorm_check) then
10441 !
10442 ! Compute the maximum elements of the gradient
10443 !
10444       gvdwc_max=0.0d0
10445       gvdwc_scp_max=0.0d0
10446       gelc_max=0.0d0
10447       gvdwpp_max=0.0d0
10448       gradb_max=0.0d0
10449       ghpbc_max=0.0d0
10450       gradcorr_max=0.0d0
10451       gel_loc_max=0.0d0
10452       gcorr3_turn_max=0.0d0
10453       gcorr4_turn_max=0.0d0
10454       gradcorr5_max=0.0d0
10455       gradcorr6_max=0.0d0
10456       gcorr6_turn_max=0.0d0
10457       gsccorc_max=0.0d0
10458       gscloc_max=0.0d0
10459       gvdwx_max=0.0d0
10460       gradx_scp_max=0.0d0
10461       ghpbx_max=0.0d0
10462       gradxorr_max=0.0d0
10463       gsccorx_max=0.0d0
10464       gsclocx_max=0.0d0
10465       do i=1,nct
10466         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10467         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10468         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10469         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10470          gvdwc_scp_max=gvdwc_scp_norm
10471         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10472         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10473         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10474         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10475         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10476         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10477         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10478         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10479         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10480         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10481         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10482         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10483         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10484           gcorr3_turn(1,i)))
10485         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10486           gcorr3_turn_max=gcorr3_turn_norm
10487         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10488           gcorr4_turn(1,i)))
10489         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10490           gcorr4_turn_max=gcorr4_turn_norm
10491         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10492         if (gradcorr5_norm.gt.gradcorr5_max) &
10493           gradcorr5_max=gradcorr5_norm
10494         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10495         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10496         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10497           gcorr6_turn(1,i)))
10498         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10499           gcorr6_turn_max=gcorr6_turn_norm
10500         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
10501         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
10502         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
10503         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
10504         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
10505         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
10506         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
10507         if (gradx_scp_norm.gt.gradx_scp_max) &
10508           gradx_scp_max=gradx_scp_norm
10509         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
10510         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
10511         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
10512         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
10513         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
10514         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
10515         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
10516         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
10517       enddo
10518       if (gradout) then
10519 #ifdef AIX
10520         open(istat,file=statname,position="append")
10521 #else
10522         open(istat,file=statname,access="append")
10523 #endif
10524         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
10525            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
10526            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
10527            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
10528            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
10529            gsccorx_max,gsclocx_max
10530         close(istat)
10531         if (gvdwc_max.gt.1.0d4) then
10532           write (iout,*) "gvdwc gvdwx gradb gradbx"
10533           do i=nnt,nct
10534             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
10535               gradb(j,i),gradbx(j,i),j=1,3)
10536           enddo
10537           call pdbout(0.0d0,'cipiszcze',iout)
10538           call flush(iout)
10539         endif
10540       endif
10541       endif
10542 !el#define DEBUG
10543 #ifdef DEBUG
10544       write (iout,*) "gradc gradx gloc"
10545       do i=1,nres
10546         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
10547          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
10548       enddo
10549 #endif
10550 !el#undef DEBUG
10551 #ifdef TIMING
10552       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
10553 #endif
10554       return
10555       end subroutine sum_gradient
10556 !-----------------------------------------------------------------------------
10557       subroutine sc_grad
10558 !      implicit real*8 (a-h,o-z)
10559       use calc_data
10560 !      include 'DIMENSIONS'
10561 !      include 'COMMON.CHAIN'
10562 !      include 'COMMON.DERIV'
10563 !      include 'COMMON.CALC'
10564 !      include 'COMMON.IOUNITS'
10565       real(kind=8), dimension(3) :: dcosom1,dcosom2
10566
10567       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
10568       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
10569       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
10570            -2.0D0*alf12*eps3der+sigder*sigsq_om12
10571 ! diagnostics only
10572 !      eom1=0.0d0
10573 !      eom2=0.0d0
10574 !      eom12=evdwij*eps1_om12
10575 ! end diagnostics
10576 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
10577 !       " sigder",sigder
10578 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
10579 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
10580 !C      print *,sss_ele_cut,'in sc_grad'
10581       do k=1,3
10582         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
10583         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
10584       enddo
10585       do k=1,3
10586         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
10587 !C      print *,'gg',k,gg(k)
10588        enddo
10589 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
10590 !      write (iout,*) "gg",(gg(k),k=1,3)
10591       do k=1,3
10592         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
10593                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10594                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
10595                   *sss_ele_cut
10596
10597         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
10598                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10599                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
10600                   *sss_ele_cut
10601
10602 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10603 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
10604 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10605 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
10606       enddo
10607 !
10608 ! Calculate the components of the gradient in DC and X
10609 !
10610 !grad      do k=i,j-1
10611 !grad        do l=1,3
10612 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
10613 !grad        enddo
10614 !grad      enddo
10615       do l=1,3
10616         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
10617         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
10618       enddo
10619       return
10620       end subroutine sc_grad
10621 #ifdef CRYST_THETA
10622 !-----------------------------------------------------------------------------
10623       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
10624
10625       use comm_calcthet
10626 !      implicit real*8 (a-h,o-z)
10627 !      include 'DIMENSIONS'
10628 !      include 'COMMON.LOCAL'
10629 !      include 'COMMON.IOUNITS'
10630 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
10631 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10632 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
10633       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
10634       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
10635 !el      integer :: it
10636 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
10637 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10638 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
10639 !el local variables
10640
10641       delthec=thetai-thet_pred_mean
10642       delthe0=thetai-theta0i
10643 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
10644       t3 = thetai-thet_pred_mean
10645       t6 = t3**2
10646       t9 = term1
10647       t12 = t3*sigcsq
10648       t14 = t12+t6*sigsqtc
10649       t16 = 1.0d0
10650       t21 = thetai-theta0i
10651       t23 = t21**2
10652       t26 = term2
10653       t27 = t21*t26
10654       t32 = termexp
10655       t40 = t32**2
10656       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
10657        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
10658        *(-t12*t9-ak*sig0inv*t27)
10659       return
10660       end subroutine mixder
10661 #endif
10662 !-----------------------------------------------------------------------------
10663 ! cartder.F
10664 !-----------------------------------------------------------------------------
10665       subroutine cartder
10666 !-----------------------------------------------------------------------------
10667 ! This subroutine calculates the derivatives of the consecutive virtual
10668 ! bond vectors and the SC vectors in the virtual-bond angles theta and
10669 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
10670 ! in the angles alpha and omega, describing the location of a side chain
10671 ! in its local coordinate system.
10672 !
10673 ! The derivatives are stored in the following arrays:
10674 !
10675 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
10676 ! The structure is as follows:
10677 !
10678 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
10679 ! 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)
10680 !         . . . . . . . . . . . .  . . . . . .
10681 ! 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)
10682 !                          .
10683 !                          .
10684 !                          .
10685 ! 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)
10686 !
10687 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
10688 ! The structure is same as above.
10689 !
10690 ! DCDS - the derivatives of the side chain vectors in the local spherical
10691 ! andgles alph and omega:
10692 !
10693 ! 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)
10694 ! 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)
10695 !                          .
10696 !                          .
10697 !                          .
10698 ! 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)
10699 !
10700 ! Version of March '95, based on an early version of November '91.
10701 !
10702 !**********************************************************************
10703 !      implicit real*8 (a-h,o-z)
10704 !      include 'DIMENSIONS'
10705 !      include 'COMMON.VAR'
10706 !      include 'COMMON.CHAIN'
10707 !      include 'COMMON.DERIV'
10708 !      include 'COMMON.GEO'
10709 !      include 'COMMON.LOCAL'
10710 !      include 'COMMON.INTERACT'
10711       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
10712       real(kind=8),dimension(3,3) :: dp,temp
10713 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
10714       real(kind=8),dimension(3) :: xx,xx1
10715 !el local variables
10716       integer :: i,k,l,j,m,ind,ind1,jjj
10717       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
10718                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
10719                  sint2,xp,yp,xxp,yyp,zzp,dj
10720
10721 !      common /przechowalnia/ fromto
10722       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
10723 ! get the position of the jth ijth fragment of the chain coordinate system
10724 ! in the fromto array.
10725 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
10726 !
10727 !      maxdim=(nres-1)*(nres-2)/2
10728 !      allocate(dcdv(6,maxdim),dxds(6,nres))
10729 ! calculate the derivatives of transformation matrix elements in theta
10730 !
10731
10732 !el      call flush(iout) !el
10733       do i=1,nres-2
10734         rdt(1,1,i)=-rt(1,2,i)
10735         rdt(1,2,i)= rt(1,1,i)
10736         rdt(1,3,i)= 0.0d0
10737         rdt(2,1,i)=-rt(2,2,i)
10738         rdt(2,2,i)= rt(2,1,i)
10739         rdt(2,3,i)= 0.0d0
10740         rdt(3,1,i)=-rt(3,2,i)
10741         rdt(3,2,i)= rt(3,1,i)
10742         rdt(3,3,i)= 0.0d0
10743       enddo
10744 !
10745 ! derivatives in phi
10746 !
10747       do i=2,nres-2
10748         drt(1,1,i)= 0.0d0
10749         drt(1,2,i)= 0.0d0
10750         drt(1,3,i)= 0.0d0
10751         drt(2,1,i)= rt(3,1,i)
10752         drt(2,2,i)= rt(3,2,i)
10753         drt(2,3,i)= rt(3,3,i)
10754         drt(3,1,i)=-rt(2,1,i)
10755         drt(3,2,i)=-rt(2,2,i)
10756         drt(3,3,i)=-rt(2,3,i)
10757       enddo
10758 !
10759 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
10760 !
10761       do i=2,nres-2
10762         ind=indmat(i,i+1)
10763         do k=1,3
10764           do l=1,3
10765             temp(k,l)=rt(k,l,i)
10766           enddo
10767         enddo
10768         do k=1,3
10769           do l=1,3
10770             fromto(k,l,ind)=temp(k,l)
10771           enddo
10772         enddo
10773         do j=i+1,nres-2
10774           ind=indmat(i,j+1)
10775           do k=1,3
10776             do l=1,3
10777               dpkl=0.0d0
10778               do m=1,3
10779                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
10780               enddo
10781               dp(k,l)=dpkl
10782               fromto(k,l,ind)=dpkl
10783             enddo
10784           enddo
10785           do k=1,3
10786             do l=1,3
10787               temp(k,l)=dp(k,l)
10788             enddo
10789           enddo
10790         enddo
10791       enddo
10792 !
10793 ! Calculate derivatives.
10794 !
10795       ind1=0
10796       do i=1,nres-2
10797         ind1=ind1+1
10798 !
10799 ! Derivatives of DC(i+1) in theta(i+2)
10800 !
10801         do j=1,3
10802           do k=1,2
10803             dpjk=0.0D0
10804             do l=1,3
10805               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
10806             enddo
10807             dp(j,k)=dpjk
10808             prordt(j,k,i)=dp(j,k)
10809           enddo
10810           dp(j,3)=0.0D0
10811           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
10812         enddo
10813 !
10814 ! Derivatives of SC(i+1) in theta(i+2)
10815 !
10816         xx1(1)=-0.5D0*xloc(2,i+1)
10817         xx1(2)= 0.5D0*xloc(1,i+1)
10818         do j=1,3
10819           xj=0.0D0
10820           do k=1,2
10821             xj=xj+r(j,k,i)*xx1(k)
10822           enddo
10823           xx(j)=xj
10824         enddo
10825         do j=1,3
10826           rj=0.0D0
10827           do k=1,3
10828             rj=rj+prod(j,k,i)*xx(k)
10829           enddo
10830           dxdv(j,ind1)=rj
10831         enddo
10832 !
10833 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
10834 ! than the other off-diagonal derivatives.
10835 !
10836         do j=1,3
10837           dxoiij=0.0D0
10838           do k=1,3
10839             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
10840           enddo
10841           dxdv(j,ind1+1)=dxoiij
10842         enddo
10843 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
10844 !
10845 ! Derivatives of DC(i+1) in phi(i+2)
10846 !
10847         do j=1,3
10848           do k=1,3
10849             dpjk=0.0
10850             do l=2,3
10851               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
10852             enddo
10853             dp(j,k)=dpjk
10854             prodrt(j,k,i)=dp(j,k)
10855           enddo
10856           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
10857         enddo
10858 !
10859 ! Derivatives of SC(i+1) in phi(i+2)
10860 !
10861         xx(1)= 0.0D0
10862         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
10863         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
10864         do j=1,3
10865           rj=0.0D0
10866           do k=2,3
10867             rj=rj+prod(j,k,i)*xx(k)
10868           enddo
10869           dxdv(j+3,ind1)=-rj
10870         enddo
10871 !
10872 ! Derivatives of SC(i+1) in phi(i+3).
10873 !
10874         do j=1,3
10875           dxoiij=0.0D0
10876           do k=1,3
10877             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
10878           enddo
10879           dxdv(j+3,ind1+1)=dxoiij
10880         enddo
10881 !
10882 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
10883 ! theta(nres) and phi(i+3) thru phi(nres).
10884 !
10885         do j=i+1,nres-2
10886           ind1=ind1+1
10887           ind=indmat(i+1,j+1)
10888 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
10889           do k=1,3
10890             do l=1,3
10891               tempkl=0.0D0
10892               do m=1,2
10893                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
10894               enddo
10895               temp(k,l)=tempkl
10896             enddo
10897           enddo
10898 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
10899 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
10900 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
10901 ! Derivatives of virtual-bond vectors in theta
10902           do k=1,3
10903             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
10904           enddo
10905 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
10906 ! Derivatives of SC vectors in theta
10907           do k=1,3
10908             dxoijk=0.0D0
10909             do l=1,3
10910               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10911             enddo
10912             dxdv(k,ind1+1)=dxoijk
10913           enddo
10914 !
10915 !--- Calculate the derivatives in phi
10916 !
10917           do k=1,3
10918             do l=1,3
10919               tempkl=0.0D0
10920               do m=1,3
10921                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
10922               enddo
10923               temp(k,l)=tempkl
10924             enddo
10925           enddo
10926           do k=1,3
10927             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
10928           enddo
10929           do k=1,3
10930             dxoijk=0.0D0
10931             do l=1,3
10932               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10933             enddo
10934             dxdv(k+3,ind1+1)=dxoijk
10935           enddo
10936         enddo
10937       enddo
10938 !
10939 ! Derivatives in alpha and omega:
10940 !
10941       do i=2,nres-1
10942 !       dsci=dsc(itype(i))
10943         dsci=vbld(i+nres)
10944 #ifdef OSF
10945         alphi=alph(i)
10946         omegi=omeg(i)
10947         if(alphi.ne.alphi) alphi=100.0
10948         if(omegi.ne.omegi) omegi=-100.0
10949 #else
10950         alphi=alph(i)
10951         omegi=omeg(i)
10952 #endif
10953 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
10954         cosalphi=dcos(alphi)
10955         sinalphi=dsin(alphi)
10956         cosomegi=dcos(omegi)
10957         sinomegi=dsin(omegi)
10958         temp(1,1)=-dsci*sinalphi
10959         temp(2,1)= dsci*cosalphi*cosomegi
10960         temp(3,1)=-dsci*cosalphi*sinomegi
10961         temp(1,2)=0.0D0
10962         temp(2,2)=-dsci*sinalphi*sinomegi
10963         temp(3,2)=-dsci*sinalphi*cosomegi
10964         theta2=pi-0.5D0*theta(i+1)
10965         cost2=dcos(theta2)
10966         sint2=dsin(theta2)
10967         jjj=0
10968 !d      print *,((temp(l,k),l=1,3),k=1,2)
10969         do j=1,2
10970           xp=temp(1,j)
10971           yp=temp(2,j)
10972           xxp= xp*cost2+yp*sint2
10973           yyp=-xp*sint2+yp*cost2
10974           zzp=temp(3,j)
10975           xx(1)=xxp
10976           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
10977           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
10978           do k=1,3
10979             dj=0.0D0
10980             do l=1,3
10981               dj=dj+prod(k,l,i-1)*xx(l)
10982             enddo
10983             dxds(jjj+k,i)=dj
10984           enddo
10985           jjj=jjj+3
10986         enddo
10987       enddo
10988       return
10989       end subroutine cartder
10990 !-----------------------------------------------------------------------------
10991 ! checkder_p.F
10992 !-----------------------------------------------------------------------------
10993       subroutine check_cartgrad
10994 ! Check the gradient of Cartesian coordinates in internal coordinates.
10995 !      implicit real*8 (a-h,o-z)
10996 !      include 'DIMENSIONS'
10997 !      include 'COMMON.IOUNITS'
10998 !      include 'COMMON.VAR'
10999 !      include 'COMMON.CHAIN'
11000 !      include 'COMMON.GEO'
11001 !      include 'COMMON.LOCAL'
11002 !      include 'COMMON.DERIV'
11003       real(kind=8),dimension(6,nres) :: temp
11004       real(kind=8),dimension(3) :: xx,gg
11005       integer :: i,k,j,ii
11006       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11007 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11008 !
11009 ! Check the gradient of the virtual-bond and SC vectors in the internal
11010 ! coordinates.
11011 !
11012       aincr=1.0d-6
11013       aincr2=5.0d-7
11014       call cartder
11015       write (iout,'(a)') '**************** dx/dalpha'
11016       write (iout,'(a)')
11017       do i=2,nres-1
11018         alphi=alph(i)
11019         alph(i)=alph(i)+aincr
11020         do k=1,3
11021           temp(k,i)=dc(k,nres+i)
11022         enddo
11023         call chainbuild
11024         do k=1,3
11025           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11026           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11027         enddo
11028         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11029         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11030         write (iout,'(a)')
11031         alph(i)=alphi
11032         call chainbuild
11033       enddo
11034       write (iout,'(a)')
11035       write (iout,'(a)') '**************** dx/domega'
11036       write (iout,'(a)')
11037       do i=2,nres-1
11038         omegi=omeg(i)
11039         omeg(i)=omeg(i)+aincr
11040         do k=1,3
11041           temp(k,i)=dc(k,nres+i)
11042         enddo
11043         call chainbuild
11044         do k=1,3
11045           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11046           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11047                 (aincr*dabs(dxds(k+3,i))+aincr))
11048         enddo
11049         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11050             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11051         write (iout,'(a)')
11052         omeg(i)=omegi
11053         call chainbuild
11054       enddo
11055       write (iout,'(a)')
11056       write (iout,'(a)') '**************** dx/dtheta'
11057       write (iout,'(a)')
11058       do i=3,nres
11059         theti=theta(i)
11060         theta(i)=theta(i)+aincr
11061         do j=i-1,nres-1
11062           do k=1,3
11063             temp(k,j)=dc(k,nres+j)
11064           enddo
11065         enddo
11066         call chainbuild
11067         do j=i-1,nres-1
11068           ii = indmat(i-2,j)
11069 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11070           do k=1,3
11071             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11072             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11073                   (aincr*dabs(dxdv(k,ii))+aincr))
11074           enddo
11075           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11076               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11077           write(iout,'(a)')
11078         enddo
11079         write (iout,'(a)')
11080         theta(i)=theti
11081         call chainbuild
11082       enddo
11083       write (iout,'(a)') '***************** dx/dphi'
11084       write (iout,'(a)')
11085       do i=4,nres
11086         phi(i)=phi(i)+aincr
11087         do j=i-1,nres-1
11088           do k=1,3
11089             temp(k,j)=dc(k,nres+j)
11090           enddo
11091         enddo
11092         call chainbuild
11093         do j=i-1,nres-1
11094           ii = indmat(i-2,j)
11095 !         print *,'ii=',ii
11096           do k=1,3
11097             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11098             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11099                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11100           enddo
11101           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11102               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11103           write(iout,'(a)')
11104         enddo
11105         phi(i)=phi(i)-aincr
11106         call chainbuild
11107       enddo
11108       write (iout,'(a)') '****************** ddc/dtheta'
11109       do i=1,nres-2
11110         thet=theta(i+2)
11111         theta(i+2)=thet+aincr
11112         do j=i,nres
11113           do k=1,3
11114             temp(k,j)=dc(k,j)
11115           enddo
11116         enddo
11117         call chainbuild
11118         do j=i+1,nres-1
11119           ii = indmat(i,j)
11120 !         print *,'ii=',ii
11121           do k=1,3
11122             gg(k)=(dc(k,j)-temp(k,j))/aincr
11123             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11124                  (aincr*dabs(dcdv(k,ii))+aincr))
11125           enddo
11126           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11127                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11128           write (iout,'(a)')
11129         enddo
11130         do j=1,nres
11131           do k=1,3
11132             dc(k,j)=temp(k,j)
11133           enddo
11134         enddo
11135         theta(i+2)=thet
11136       enddo
11137       write (iout,'(a)') '******************* ddc/dphi'
11138       do i=1,nres-3
11139         phii=phi(i+3)
11140         phi(i+3)=phii+aincr
11141         do j=1,nres
11142           do k=1,3
11143             temp(k,j)=dc(k,j)
11144           enddo
11145         enddo
11146         call chainbuild
11147         do j=i+2,nres-1
11148           ii = indmat(i+1,j)
11149 !         print *,'ii=',ii
11150           do k=1,3
11151             gg(k)=(dc(k,j)-temp(k,j))/aincr
11152             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11153                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11154           enddo
11155           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11156                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11157           write (iout,'(a)')
11158         enddo
11159         do j=1,nres
11160           do k=1,3
11161             dc(k,j)=temp(k,j)
11162           enddo
11163         enddo
11164         phi(i+3)=phii
11165       enddo
11166       return
11167       end subroutine check_cartgrad
11168 !-----------------------------------------------------------------------------
11169       subroutine check_ecart
11170 ! Check the gradient of the energy in Cartesian coordinates.
11171 !     implicit real*8 (a-h,o-z)
11172 !     include 'DIMENSIONS'
11173 !     include 'COMMON.CHAIN'
11174 !     include 'COMMON.DERIV'
11175 !     include 'COMMON.IOUNITS'
11176 !     include 'COMMON.VAR'
11177 !     include 'COMMON.CONTACTS'
11178       use comm_srutu
11179 !el      integer :: icall
11180 !el      common /srutu/ icall
11181       real(kind=8),dimension(6) :: ggg
11182       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11183       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11184       real(kind=8),dimension(6,nres) :: grad_s
11185       real(kind=8),dimension(0:n_ene) :: energia,energia1
11186       integer :: uiparm(1)
11187       real(kind=8) :: urparm(1)
11188 !EL      external fdum
11189       integer :: nf,i,j,k
11190       real(kind=8) :: aincr,etot,etot1
11191       icg=1
11192       nf=0
11193       nfl=0
11194       call zerograd
11195       aincr=1.0D-5
11196       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11197       nf=0
11198       icall=0
11199       call geom_to_var(nvar,x)
11200       call etotal(energia)
11201       etot=energia(0)
11202 !el      call enerprint(energia)
11203       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11204       icall =1
11205       do i=1,nres
11206         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11207       enddo
11208       do i=1,nres
11209         do j=1,3
11210           grad_s(j,i)=gradc(j,i,icg)
11211           grad_s(j+3,i)=gradx(j,i,icg)
11212         enddo
11213       enddo
11214       call flush(iout)
11215       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11216       do i=1,nres
11217         do j=1,3
11218           xx(j)=c(j,i+nres)
11219           ddc(j)=dc(j,i)
11220           ddx(j)=dc(j,i+nres)
11221         enddo
11222         do j=1,3
11223           dc(j,i)=dc(j,i)+aincr
11224           do k=i+1,nres
11225             c(j,k)=c(j,k)+aincr
11226             c(j,k+nres)=c(j,k+nres)+aincr
11227           enddo
11228           call etotal(energia1)
11229           etot1=energia1(0)
11230           ggg(j)=(etot1-etot)/aincr
11231           dc(j,i)=ddc(j)
11232           do k=i+1,nres
11233             c(j,k)=c(j,k)-aincr
11234             c(j,k+nres)=c(j,k+nres)-aincr
11235           enddo
11236         enddo
11237         do j=1,3
11238           c(j,i+nres)=c(j,i+nres)+aincr
11239           dc(j,i+nres)=dc(j,i+nres)+aincr
11240           call etotal(energia1)
11241           etot1=energia1(0)
11242           ggg(j+3)=(etot1-etot)/aincr
11243           c(j,i+nres)=xx(j)
11244           dc(j,i+nres)=ddx(j)
11245         enddo
11246         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11247          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11248       enddo
11249       return
11250       end subroutine check_ecart
11251 #ifdef CARGRAD
11252 !-----------------------------------------------------------------------------
11253       subroutine check_ecartint
11254 ! Check the gradient of the energy in Cartesian coordinates.
11255       use io_base, only: intout
11256 !      implicit real*8 (a-h,o-z)
11257 !      include 'DIMENSIONS'
11258 !      include 'COMMON.CONTROL'
11259 !      include 'COMMON.CHAIN'
11260 !      include 'COMMON.DERIV'
11261 !      include 'COMMON.IOUNITS'
11262 !      include 'COMMON.VAR'
11263 !      include 'COMMON.CONTACTS'
11264 !      include 'COMMON.MD'
11265 !      include 'COMMON.LOCAL'
11266 !      include 'COMMON.SPLITELE'
11267       use comm_srutu
11268 !el      integer :: icall
11269 !el      common /srutu/ icall
11270       real(kind=8),dimension(6) :: ggg,ggg1
11271       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11272       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11273       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11274       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11275       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11276       real(kind=8),dimension(0:n_ene) :: energia,energia1
11277       integer :: uiparm(1)
11278       real(kind=8) :: urparm(1)
11279 !EL      external fdum
11280       integer :: i,j,k,nf
11281       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11282                    etot21,etot22
11283       r_cut=2.0d0
11284       rlambd=0.3d0
11285       icg=1
11286       nf=0
11287       nfl=0
11288       call intout
11289 !      call intcartderiv
11290 !      call checkintcartgrad
11291       call zerograd
11292       aincr=1.0D-5
11293       write(iout,*) 'Calling CHECK_ECARTINT.'
11294       nf=0
11295       icall=0
11296       write (iout,*) "Before geom_to_var"
11297       call geom_to_var(nvar,x)
11298       write (iout,*) "after geom_to_var"
11299       write (iout,*) "split_ene ",split_ene
11300       call flush(iout)
11301       if (.not.split_ene) then
11302         write(iout,*) 'Calling CHECK_ECARTINT if'
11303         call etotal(energia)
11304 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11305         etot=energia(0)
11306         write (iout,*) "etot",etot
11307         call flush(iout)
11308 !el        call enerprint(energia)
11309 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11310         call flush(iout)
11311         write (iout,*) "enter cartgrad"
11312         call flush(iout)
11313         call cartgrad
11314 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11315         write (iout,*) "exit cartgrad"
11316         call flush(iout)
11317         icall =1
11318         do i=1,nres
11319           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11320         enddo
11321         do j=1,3
11322           grad_s(j,0)=gcart(j,0)
11323         enddo
11324 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11325         do i=1,nres
11326           do j=1,3
11327             grad_s(j,i)=gcart(j,i)
11328             grad_s(j+3,i)=gxcart(j,i)
11329           enddo
11330         enddo
11331       else
11332 write(iout,*) 'Calling CHECK_ECARTIN else.'
11333 !- split gradient check
11334         call zerograd
11335         call etotal_long(energia)
11336 !el        call enerprint(energia)
11337         call flush(iout)
11338         write (iout,*) "enter cartgrad"
11339         call flush(iout)
11340         call cartgrad
11341         write (iout,*) "exit cartgrad"
11342         call flush(iout)
11343         icall =1
11344         write (iout,*) "longrange grad"
11345         do i=1,nres
11346           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11347           (gxcart(j,i),j=1,3)
11348         enddo
11349         do j=1,3
11350           grad_s(j,0)=gcart(j,0)
11351         enddo
11352         do i=1,nres
11353           do j=1,3
11354             grad_s(j,i)=gcart(j,i)
11355             grad_s(j+3,i)=gxcart(j,i)
11356           enddo
11357         enddo
11358         call zerograd
11359         call etotal_short(energia)
11360 !el        call enerprint(energia)
11361         call flush(iout)
11362         write (iout,*) "enter cartgrad"
11363         call flush(iout)
11364         call cartgrad
11365         write (iout,*) "exit cartgrad"
11366         call flush(iout)
11367         icall =1
11368         write (iout,*) "shortrange grad"
11369         do i=1,nres
11370           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11371           (gxcart(j,i),j=1,3)
11372         enddo
11373         do j=1,3
11374           grad_s1(j,0)=gcart(j,0)
11375         enddo
11376         do i=1,nres
11377           do j=1,3
11378             grad_s1(j,i)=gcart(j,i)
11379             grad_s1(j+3,i)=gxcart(j,i)
11380           enddo
11381         enddo
11382       endif
11383       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11384 !      do i=1,nres
11385       do i=nnt,nct
11386         do j=1,3
11387           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11388           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11389           ddc(j)=c(j,i)
11390           ddx(j)=c(j,i+nres)
11391           dcnorm_safe1(j)=dc_norm(j,i-1)
11392           dcnorm_safe2(j)=dc_norm(j,i)
11393           dxnorm_safe(j)=dc_norm(j,i+nres)
11394         enddo
11395         do j=1,3
11396           c(j,i)=ddc(j)+aincr
11397           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11398           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11399           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11400           dc(j,i)=c(j,i+1)-c(j,i)
11401           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11402           call int_from_cart1(.false.)
11403           if (.not.split_ene) then
11404             call etotal(energia1)
11405             etot1=energia1(0)
11406             write (iout,*) "ij",i,j," etot1",etot1
11407           else
11408 !- split gradient
11409             call etotal_long(energia1)
11410             etot11=energia1(0)
11411             call etotal_short(energia1)
11412             etot12=energia1(0)
11413           endif
11414 !- end split gradient
11415 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11416           c(j,i)=ddc(j)-aincr
11417           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11418           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11419           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11420           dc(j,i)=c(j,i+1)-c(j,i)
11421           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11422           call int_from_cart1(.false.)
11423           if (.not.split_ene) then
11424             call etotal(energia1)
11425             etot2=energia1(0)
11426             write (iout,*) "ij",i,j," etot2",etot2
11427             ggg(j)=(etot1-etot2)/(2*aincr)
11428           else
11429 !- split gradient
11430             call etotal_long(energia1)
11431             etot21=energia1(0)
11432             ggg(j)=(etot11-etot21)/(2*aincr)
11433             call etotal_short(energia1)
11434             etot22=energia1(0)
11435             ggg1(j)=(etot12-etot22)/(2*aincr)
11436 !- end split gradient
11437 !            write (iout,*) "etot21",etot21," etot22",etot22
11438           endif
11439 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11440           c(j,i)=ddc(j)
11441           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11442           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11443           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11444           dc(j,i)=c(j,i+1)-c(j,i)
11445           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11446           dc_norm(j,i-1)=dcnorm_safe1(j)
11447           dc_norm(j,i)=dcnorm_safe2(j)
11448           dc_norm(j,i+nres)=dxnorm_safe(j)
11449         enddo
11450         do j=1,3
11451           c(j,i+nres)=ddx(j)+aincr
11452           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11453           call int_from_cart1(.false.)
11454           if (.not.split_ene) then
11455             call etotal(energia1)
11456             etot1=energia1(0)
11457           else
11458 !- split gradient
11459             call etotal_long(energia1)
11460             etot11=energia1(0)
11461             call etotal_short(energia1)
11462             etot12=energia1(0)
11463           endif
11464 !- end split gradient
11465           c(j,i+nres)=ddx(j)-aincr
11466           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11467           call int_from_cart1(.false.)
11468           if (.not.split_ene) then
11469             call etotal(energia1)
11470             etot2=energia1(0)
11471             ggg(j+3)=(etot1-etot2)/(2*aincr)
11472           else
11473 !- split gradient
11474             call etotal_long(energia1)
11475             etot21=energia1(0)
11476             ggg(j+3)=(etot11-etot21)/(2*aincr)
11477             call etotal_short(energia1)
11478             etot22=energia1(0)
11479             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11480 !- end split gradient
11481           endif
11482 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11483           c(j,i+nres)=ddx(j)
11484           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11485           dc_norm(j,i+nres)=dxnorm_safe(j)
11486           call int_from_cart1(.false.)
11487         enddo
11488         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11489          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11490         if (split_ene) then
11491           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11492          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11493          k=1,6)
11494          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11495          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11496          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11497         endif
11498       enddo
11499       return
11500       end subroutine check_ecartint
11501 #else
11502 !-----------------------------------------------------------------------------
11503       subroutine check_ecartint
11504 ! Check the gradient of the energy in Cartesian coordinates.
11505       use io_base, only: intout
11506 !      implicit real*8 (a-h,o-z)
11507 !      include 'DIMENSIONS'
11508 !      include 'COMMON.CONTROL'
11509 !      include 'COMMON.CHAIN'
11510 !      include 'COMMON.DERIV'
11511 !      include 'COMMON.IOUNITS'
11512 !      include 'COMMON.VAR'
11513 !      include 'COMMON.CONTACTS'
11514 !      include 'COMMON.MD'
11515 !      include 'COMMON.LOCAL'
11516 !      include 'COMMON.SPLITELE'
11517       use comm_srutu
11518 !el      integer :: icall
11519 !el      common /srutu/ icall
11520       real(kind=8),dimension(6) :: ggg,ggg1
11521       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11522       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11523       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
11524       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11525       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11526       real(kind=8),dimension(0:n_ene) :: energia,energia1
11527       integer :: uiparm(1)
11528       real(kind=8) :: urparm(1)
11529 !EL      external fdum
11530       integer :: i,j,k,nf
11531       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11532                    etot21,etot22
11533       r_cut=2.0d0
11534       rlambd=0.3d0
11535       icg=1
11536       nf=0
11537       nfl=0
11538       call intout
11539 !      call intcartderiv
11540 !      call checkintcartgrad
11541       call zerograd
11542       aincr=2.0D-5
11543       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
11544       nf=0
11545       icall=0
11546       call geom_to_var(nvar,x)
11547       if (.not.split_ene) then
11548         call etotal(energia)
11549         etot=energia(0)
11550 !el        call enerprint(energia)
11551         call flush(iout)
11552         write (iout,*) "enter cartgrad"
11553         call flush(iout)
11554         call cartgrad
11555         write (iout,*) "exit cartgrad"
11556         call flush(iout)
11557         icall =1
11558         do i=1,nres
11559           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11560         enddo
11561         do j=1,3
11562           grad_s(j,0)=gcart(j,0)
11563         enddo
11564         do i=1,nres
11565           do j=1,3
11566             grad_s(j,i)=gcart(j,i)
11567             grad_s(j+3,i)=gxcart(j,i)
11568           enddo
11569         enddo
11570       else
11571 !- split gradient check
11572         call zerograd
11573         call etotal_long(energia)
11574 !el        call enerprint(energia)
11575         call flush(iout)
11576         write (iout,*) "enter cartgrad"
11577         call flush(iout)
11578         call cartgrad
11579         write (iout,*) "exit cartgrad"
11580         call flush(iout)
11581         icall =1
11582         write (iout,*) "longrange grad"
11583         do i=1,nres
11584           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11585           (gxcart(j,i),j=1,3)
11586         enddo
11587         do j=1,3
11588           grad_s(j,0)=gcart(j,0)
11589         enddo
11590         do i=1,nres
11591           do j=1,3
11592             grad_s(j,i)=gcart(j,i)
11593             grad_s(j+3,i)=gxcart(j,i)
11594           enddo
11595         enddo
11596         call zerograd
11597         call etotal_short(energia)
11598 !el        call enerprint(energia)
11599         call flush(iout)
11600         write (iout,*) "enter cartgrad"
11601         call flush(iout)
11602         call cartgrad
11603         write (iout,*) "exit cartgrad"
11604         call flush(iout)
11605         icall =1
11606         write (iout,*) "shortrange grad"
11607         do i=1,nres
11608           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11609           (gxcart(j,i),j=1,3)
11610         enddo
11611         do j=1,3
11612           grad_s1(j,0)=gcart(j,0)
11613         enddo
11614         do i=1,nres
11615           do j=1,3
11616             grad_s1(j,i)=gcart(j,i)
11617             grad_s1(j+3,i)=gxcart(j,i)
11618           enddo
11619         enddo
11620       endif
11621       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11622       do i=0,nres
11623         do j=1,3
11624           xx(j)=c(j,i+nres)
11625           ddc(j)=dc(j,i)
11626           ddx(j)=dc(j,i+nres)
11627           do k=1,3
11628             dcnorm_safe(k)=dc_norm(k,i)
11629             dxnorm_safe(k)=dc_norm(k,i+nres)
11630           enddo
11631         enddo
11632         do j=1,3
11633           dc(j,i)=ddc(j)+aincr
11634           call chainbuild_cart
11635 #ifdef MPI
11636 ! Broadcast the order to compute internal coordinates to the slaves.
11637 !          if (nfgtasks.gt.1)
11638 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
11639 #endif
11640 !          call int_from_cart1(.false.)
11641           if (.not.split_ene) then
11642             call etotal(energia1)
11643             etot1=energia1(0)
11644           else
11645 !- split gradient
11646             call etotal_long(energia1)
11647             etot11=energia1(0)
11648             call etotal_short(energia1)
11649             etot12=energia1(0)
11650 !            write (iout,*) "etot11",etot11," etot12",etot12
11651           endif
11652 !- end split gradient
11653 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11654           dc(j,i)=ddc(j)-aincr
11655           call chainbuild_cart
11656 !          call int_from_cart1(.false.)
11657           if (.not.split_ene) then
11658             call etotal(energia1)
11659             etot2=energia1(0)
11660             ggg(j)=(etot1-etot2)/(2*aincr)
11661           else
11662 !- split gradient
11663             call etotal_long(energia1)
11664             etot21=energia1(0)
11665             ggg(j)=(etot11-etot21)/(2*aincr)
11666             call etotal_short(energia1)
11667             etot22=energia1(0)
11668             ggg1(j)=(etot12-etot22)/(2*aincr)
11669 !- end split gradient
11670 !            write (iout,*) "etot21",etot21," etot22",etot22
11671           endif
11672 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11673           dc(j,i)=ddc(j)
11674           call chainbuild_cart
11675         enddo
11676         do j=1,3
11677           dc(j,i+nres)=ddx(j)+aincr
11678           call chainbuild_cart
11679 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
11680 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11681 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11682 !          write (iout,*) "dxnormnorm",dsqrt(
11683 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11684 !          write (iout,*) "dxnormnormsafe",dsqrt(
11685 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11686 !          write (iout,*)
11687           if (.not.split_ene) then
11688             call etotal(energia1)
11689             etot1=energia1(0)
11690           else
11691 !- split gradient
11692             call etotal_long(energia1)
11693             etot11=energia1(0)
11694             call etotal_short(energia1)
11695             etot12=energia1(0)
11696           endif
11697 !- end split gradient
11698 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11699           dc(j,i+nres)=ddx(j)-aincr
11700           call chainbuild_cart
11701 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
11702 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11703 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11704 !          write (iout,*)
11705 !          write (iout,*) "dxnormnorm",dsqrt(
11706 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11707 !          write (iout,*) "dxnormnormsafe",dsqrt(
11708 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11709           if (.not.split_ene) then
11710             call etotal(energia1)
11711             etot2=energia1(0)
11712             ggg(j+3)=(etot1-etot2)/(2*aincr)
11713           else
11714 !- split gradient
11715             call etotal_long(energia1)
11716             etot21=energia1(0)
11717             ggg(j+3)=(etot11-etot21)/(2*aincr)
11718             call etotal_short(energia1)
11719             etot22=energia1(0)
11720             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11721 !- end split gradient
11722           endif
11723 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11724           dc(j,i+nres)=ddx(j)
11725           call chainbuild_cart
11726         enddo
11727         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11728          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11729         if (split_ene) then
11730           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11731          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11732          k=1,6)
11733          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11734          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11735          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11736         endif
11737       enddo
11738       return
11739       end subroutine check_ecartint
11740 #endif
11741 !-----------------------------------------------------------------------------
11742       subroutine check_eint
11743 ! Check the gradient of energy in internal coordinates.
11744 !      implicit real*8 (a-h,o-z)
11745 !      include 'DIMENSIONS'
11746 !      include 'COMMON.CHAIN'
11747 !      include 'COMMON.DERIV'
11748 !      include 'COMMON.IOUNITS'
11749 !      include 'COMMON.VAR'
11750 !      include 'COMMON.GEO'
11751       use comm_srutu
11752 !el      integer :: icall
11753 !el      common /srutu/ icall
11754       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
11755       integer :: uiparm(1)
11756       real(kind=8) :: urparm(1)
11757       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
11758       character(len=6) :: key
11759 !EL      external fdum
11760       integer :: i,ii,nf
11761       real(kind=8) :: xi,aincr,etot,etot1,etot2
11762       call zerograd
11763       aincr=1.0D-7
11764       print '(a)','Calling CHECK_INT.'
11765       nf=0
11766       nfl=0
11767       icg=1
11768       call geom_to_var(nvar,x)
11769       call var_to_geom(nvar,x)
11770       call chainbuild
11771       icall=1
11772       print *,'ICG=',ICG
11773       call etotal(energia)
11774       etot = energia(0)
11775 !el      call enerprint(energia)
11776       print *,'ICG=',ICG
11777 #ifdef MPL
11778       if (MyID.ne.BossID) then
11779         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
11780         nf=x(nvar+1)
11781         nfl=x(nvar+2)
11782         icg=x(nvar+3)
11783       endif
11784 #endif
11785       nf=1
11786       nfl=3
11787 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
11788       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
11789 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
11790       icall=1
11791       do i=1,nvar
11792         xi=x(i)
11793         x(i)=xi-0.5D0*aincr
11794         call var_to_geom(nvar,x)
11795         call chainbuild
11796         call etotal(energia1)
11797         etot1=energia1(0)
11798         x(i)=xi+0.5D0*aincr
11799         call var_to_geom(nvar,x)
11800         call chainbuild
11801         call etotal(energia2)
11802         etot2=energia2(0)
11803         gg(i)=(etot2-etot1)/aincr
11804         write (iout,*) i,etot1,etot2
11805         x(i)=xi
11806       enddo
11807       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
11808           '     RelDiff*100% '
11809       do i=1,nvar
11810         if (i.le.nphi) then
11811           ii=i
11812           key = ' phi'
11813         else if (i.le.nphi+ntheta) then
11814           ii=i-nphi
11815           key=' theta'
11816         else if (i.le.nphi+ntheta+nside) then
11817            ii=i-(nphi+ntheta)
11818            key=' alpha'
11819         else
11820            ii=i-(nphi+ntheta+nside)
11821            key=' omega'
11822         endif
11823         write (iout,'(i3,a,i3,3(1pd16.6))') &
11824        i,key,ii,gg(i),gana(i),&
11825        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
11826       enddo
11827       return
11828       end subroutine check_eint
11829 !-----------------------------------------------------------------------------
11830 ! econstr_local.F
11831 !-----------------------------------------------------------------------------
11832       subroutine Econstr_back
11833 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
11834 !      implicit real*8 (a-h,o-z)
11835 !      include 'DIMENSIONS'
11836 !      include 'COMMON.CONTROL'
11837 !      include 'COMMON.VAR'
11838 !      include 'COMMON.MD'
11839       use MD_data
11840 !#ifndef LANG0
11841 !      include 'COMMON.LANGEVIN'
11842 !#else
11843 !      include 'COMMON.LANGEVIN.lang0'
11844 !#endif
11845 !      include 'COMMON.CHAIN'
11846 !      include 'COMMON.DERIV'
11847 !      include 'COMMON.GEO'
11848 !      include 'COMMON.LOCAL'
11849 !      include 'COMMON.INTERACT'
11850 !      include 'COMMON.IOUNITS'
11851 !      include 'COMMON.NAMES'
11852 !      include 'COMMON.TIME1'
11853       integer :: i,j,ii,k
11854       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
11855
11856       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
11857       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
11858       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
11859
11860       Uconst_back=0.0d0
11861       do i=1,nres
11862         dutheta(i)=0.0d0
11863         dugamma(i)=0.0d0
11864         do j=1,3
11865           duscdiff(j,i)=0.0d0
11866           duscdiffx(j,i)=0.0d0
11867         enddo
11868       enddo
11869       do i=1,nfrag_back
11870         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
11871 !
11872 ! Deviations from theta angles
11873 !
11874         utheta_i=0.0d0
11875         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
11876           dtheta_i=theta(j)-thetaref(j)
11877           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
11878           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
11879         enddo
11880         utheta(i)=utheta_i/(ii-1)
11881 !
11882 ! Deviations from gamma angles
11883 !
11884         ugamma_i=0.0d0
11885         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
11886           dgamma_i=pinorm(phi(j)-phiref(j))
11887 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
11888           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
11889           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
11890 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
11891         enddo
11892         ugamma(i)=ugamma_i/(ii-2)
11893 !
11894 ! Deviations from local SC geometry
11895 !
11896         uscdiff(i)=0.0d0
11897         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
11898           dxx=xxtab(j)-xxref(j)
11899           dyy=yytab(j)-yyref(j)
11900           dzz=zztab(j)-zzref(j)
11901           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
11902           do k=1,3
11903             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
11904              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
11905              (ii-1)
11906             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
11907              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
11908              (ii-1)
11909             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
11910            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
11911             /(ii-1)
11912           enddo
11913 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
11914 !     &      xxref(j),yyref(j),zzref(j)
11915         enddo
11916         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
11917 !        write (iout,*) i," uscdiff",uscdiff(i)
11918 !
11919 ! Put together deviations from local geometry
11920 !
11921         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
11922           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
11923 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
11924 !     &   " uconst_back",uconst_back
11925         utheta(i)=dsqrt(utheta(i))
11926         ugamma(i)=dsqrt(ugamma(i))
11927         uscdiff(i)=dsqrt(uscdiff(i))
11928       enddo
11929       return
11930       end subroutine Econstr_back
11931 !-----------------------------------------------------------------------------
11932 ! energy_p_new-sep_barrier.F
11933 !-----------------------------------------------------------------------------
11934       real(kind=8) function sscale(r)
11935 !      include "COMMON.SPLITELE"
11936       real(kind=8) :: r,gamm
11937       if(r.lt.r_cut-rlamb) then
11938         sscale=1.0d0
11939       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11940         gamm=(r-(r_cut-rlamb))/rlamb
11941         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11942       else
11943         sscale=0d0
11944       endif
11945       return
11946       end function sscale
11947       real(kind=8) function sscale_grad(r)
11948 !      include "COMMON.SPLITELE"
11949       real(kind=8) :: r,gamm
11950       if(r.lt.r_cut-rlamb) then
11951         sscale_grad=0.0d0
11952       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11953         gamm=(r-(r_cut-rlamb))/rlamb
11954         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
11955       else
11956         sscale_grad=0d0
11957       endif
11958       return
11959       end function sscale_grad
11960
11961 !!!!!!!!!! PBCSCALE
11962       real(kind=8) function sscale_ele(r)
11963 !      include "COMMON.SPLITELE"
11964       real(kind=8) :: r,gamm
11965       if(r.lt.r_cut_ele-rlamb_ele) then
11966         sscale_ele=1.0d0
11967       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11968         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11969         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11970       else
11971         sscale_ele=0d0
11972       endif
11973       return
11974       end function sscale_ele
11975
11976       real(kind=8)  function sscagrad_ele(r)
11977       real(kind=8) :: r,gamm
11978 !      include "COMMON.SPLITELE"
11979       if(r.lt.r_cut_ele-rlamb_ele) then
11980         sscagrad_ele=0.0d0
11981       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11982         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11983         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
11984       else
11985         sscagrad_ele=0.0d0
11986       endif
11987       return
11988       end function sscagrad_ele
11989       real(kind=8) function sscalelip(r)
11990       real(kind=8) r,gamm
11991         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
11992       return
11993       end function sscalelip
11994 !C-----------------------------------------------------------------------
11995       real(kind=8) function sscagradlip(r)
11996       real(kind=8) r,gamm
11997         sscagradlip=r*(6.0d0*r-6.0d0)
11998       return
11999       end function sscagradlip
12000
12001 !!!!!!!!!!!!!!!
12002 !-----------------------------------------------------------------------------
12003       subroutine elj_long(evdw)
12004 !
12005 ! This subroutine calculates the interaction energy of nonbonded side chains
12006 ! assuming the LJ potential of interaction.
12007 !
12008 !      implicit real*8 (a-h,o-z)
12009 !      include 'DIMENSIONS'
12010 !      include 'COMMON.GEO'
12011 !      include 'COMMON.VAR'
12012 !      include 'COMMON.LOCAL'
12013 !      include 'COMMON.CHAIN'
12014 !      include 'COMMON.DERIV'
12015 !      include 'COMMON.INTERACT'
12016 !      include 'COMMON.TORSION'
12017 !      include 'COMMON.SBRIDGE'
12018 !      include 'COMMON.NAMES'
12019 !      include 'COMMON.IOUNITS'
12020 !      include 'COMMON.CONTACTS'
12021       real(kind=8),parameter :: accur=1.0d-10
12022       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12023 !el local variables
12024       integer :: i,iint,j,k,itypi,itypi1,itypj
12025       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12026       real(kind=8) :: e1,e2,evdwij,evdw
12027 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12028       evdw=0.0D0
12029       do i=iatsc_s,iatsc_e
12030         itypi=itype(i)
12031         if (itypi.eq.ntyp1) cycle
12032         itypi1=itype(i+1)
12033         xi=c(1,nres+i)
12034         yi=c(2,nres+i)
12035         zi=c(3,nres+i)
12036 !
12037 ! Calculate SC interaction energy.
12038 !
12039         do iint=1,nint_gr(i)
12040 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12041 !d   &                  'iend=',iend(i,iint)
12042           do j=istart(i,iint),iend(i,iint)
12043             itypj=itype(j)
12044             if (itypj.eq.ntyp1) cycle
12045             xj=c(1,nres+j)-xi
12046             yj=c(2,nres+j)-yi
12047             zj=c(3,nres+j)-zi
12048             rij=xj*xj+yj*yj+zj*zj
12049             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12050             if (sss.lt.1.0d0) then
12051               rrij=1.0D0/rij
12052               eps0ij=eps(itypi,itypj)
12053               fac=rrij**expon2
12054               e1=fac*fac*aa_aq(itypi,itypj)
12055               e2=fac*bb_aq(itypi,itypj)
12056               evdwij=e1+e2
12057               evdw=evdw+(1.0d0-sss)*evdwij
12058 !
12059 ! Calculate the components of the gradient in DC and X
12060 !
12061               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12062               gg(1)=xj*fac
12063               gg(2)=yj*fac
12064               gg(3)=zj*fac
12065               do k=1,3
12066                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12067                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12068                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12069                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12070               enddo
12071             endif
12072           enddo      ! j
12073         enddo        ! iint
12074       enddo          ! i
12075       do i=1,nct
12076         do j=1,3
12077           gvdwc(j,i)=expon*gvdwc(j,i)
12078           gvdwx(j,i)=expon*gvdwx(j,i)
12079         enddo
12080       enddo
12081 !******************************************************************************
12082 !
12083 !                              N O T E !!!
12084 !
12085 ! To save time, the factor of EXPON has been extracted from ALL components
12086 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12087 ! use!
12088 !
12089 !******************************************************************************
12090       return
12091       end subroutine elj_long
12092 !-----------------------------------------------------------------------------
12093       subroutine elj_short(evdw)
12094 !
12095 ! This subroutine calculates the interaction energy of nonbonded side chains
12096 ! assuming the LJ potential of interaction.
12097 !
12098 !      implicit real*8 (a-h,o-z)
12099 !      include 'DIMENSIONS'
12100 !      include 'COMMON.GEO'
12101 !      include 'COMMON.VAR'
12102 !      include 'COMMON.LOCAL'
12103 !      include 'COMMON.CHAIN'
12104 !      include 'COMMON.DERIV'
12105 !      include 'COMMON.INTERACT'
12106 !      include 'COMMON.TORSION'
12107 !      include 'COMMON.SBRIDGE'
12108 !      include 'COMMON.NAMES'
12109 !      include 'COMMON.IOUNITS'
12110 !      include 'COMMON.CONTACTS'
12111       real(kind=8),parameter :: accur=1.0d-10
12112       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12113 !el local variables
12114       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12115       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12116       real(kind=8) :: e1,e2,evdwij,evdw
12117 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12118       evdw=0.0D0
12119       do i=iatsc_s,iatsc_e
12120         itypi=itype(i)
12121         if (itypi.eq.ntyp1) cycle
12122         itypi1=itype(i+1)
12123         xi=c(1,nres+i)
12124         yi=c(2,nres+i)
12125         zi=c(3,nres+i)
12126 ! Change 12/1/95
12127         num_conti=0
12128 !
12129 ! Calculate SC interaction energy.
12130 !
12131         do iint=1,nint_gr(i)
12132 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12133 !d   &                  'iend=',iend(i,iint)
12134           do j=istart(i,iint),iend(i,iint)
12135             itypj=itype(j)
12136             if (itypj.eq.ntyp1) cycle
12137             xj=c(1,nres+j)-xi
12138             yj=c(2,nres+j)-yi
12139             zj=c(3,nres+j)-zi
12140 ! Change 12/1/95 to calculate four-body interactions
12141             rij=xj*xj+yj*yj+zj*zj
12142             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12143             if (sss.gt.0.0d0) then
12144               rrij=1.0D0/rij
12145               eps0ij=eps(itypi,itypj)
12146               fac=rrij**expon2
12147               e1=fac*fac*aa_aq(itypi,itypj)
12148               e2=fac*bb_aq(itypi,itypj)
12149               evdwij=e1+e2
12150               evdw=evdw+sss*evdwij
12151 !
12152 ! Calculate the components of the gradient in DC and X
12153 !
12154               fac=-rrij*(e1+evdwij)*sss
12155               gg(1)=xj*fac
12156               gg(2)=yj*fac
12157               gg(3)=zj*fac
12158               do k=1,3
12159                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12160                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12161                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12162                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12163               enddo
12164             endif
12165           enddo      ! j
12166         enddo        ! iint
12167       enddo          ! i
12168       do i=1,nct
12169         do j=1,3
12170           gvdwc(j,i)=expon*gvdwc(j,i)
12171           gvdwx(j,i)=expon*gvdwx(j,i)
12172         enddo
12173       enddo
12174 !******************************************************************************
12175 !
12176 !                              N O T E !!!
12177 !
12178 ! To save time, the factor of EXPON has been extracted from ALL components
12179 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12180 ! use!
12181 !
12182 !******************************************************************************
12183       return
12184       end subroutine elj_short
12185 !-----------------------------------------------------------------------------
12186       subroutine eljk_long(evdw)
12187 !
12188 ! This subroutine calculates the interaction energy of nonbonded side chains
12189 ! assuming the LJK potential of interaction.
12190 !
12191 !      implicit real*8 (a-h,o-z)
12192 !      include 'DIMENSIONS'
12193 !      include 'COMMON.GEO'
12194 !      include 'COMMON.VAR'
12195 !      include 'COMMON.LOCAL'
12196 !      include 'COMMON.CHAIN'
12197 !      include 'COMMON.DERIV'
12198 !      include 'COMMON.INTERACT'
12199 !      include 'COMMON.IOUNITS'
12200 !      include 'COMMON.NAMES'
12201       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12202       logical :: scheck
12203 !el local variables
12204       integer :: i,iint,j,k,itypi,itypi1,itypj
12205       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12206                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12207 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12208       evdw=0.0D0
12209       do i=iatsc_s,iatsc_e
12210         itypi=itype(i)
12211         if (itypi.eq.ntyp1) cycle
12212         itypi1=itype(i+1)
12213         xi=c(1,nres+i)
12214         yi=c(2,nres+i)
12215         zi=c(3,nres+i)
12216 !
12217 ! Calculate SC interaction energy.
12218 !
12219         do iint=1,nint_gr(i)
12220           do j=istart(i,iint),iend(i,iint)
12221             itypj=itype(j)
12222             if (itypj.eq.ntyp1) cycle
12223             xj=c(1,nres+j)-xi
12224             yj=c(2,nres+j)-yi
12225             zj=c(3,nres+j)-zi
12226             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12227             fac_augm=rrij**expon
12228             e_augm=augm(itypi,itypj)*fac_augm
12229             r_inv_ij=dsqrt(rrij)
12230             rij=1.0D0/r_inv_ij
12231             sss=sscale(rij/sigma(itypi,itypj))
12232             if (sss.lt.1.0d0) then
12233               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12234               fac=r_shift_inv**expon
12235               e1=fac*fac*aa_aq(itypi,itypj)
12236               e2=fac*bb_aq(itypi,itypj)
12237               evdwij=e_augm+e1+e2
12238 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12239 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12240 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12241 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
12242 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12243 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12244 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12245               evdw=evdw+(1.0d0-sss)*evdwij
12246 !
12247 ! Calculate the components of the gradient in DC and X
12248 !
12249               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12250               fac=fac*(1.0d0-sss)
12251               gg(1)=xj*fac
12252               gg(2)=yj*fac
12253               gg(3)=zj*fac
12254               do k=1,3
12255                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12256                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12257                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12258                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12259               enddo
12260             endif
12261           enddo      ! j
12262         enddo        ! iint
12263       enddo          ! i
12264       do i=1,nct
12265         do j=1,3
12266           gvdwc(j,i)=expon*gvdwc(j,i)
12267           gvdwx(j,i)=expon*gvdwx(j,i)
12268         enddo
12269       enddo
12270       return
12271       end subroutine eljk_long
12272 !-----------------------------------------------------------------------------
12273       subroutine eljk_short(evdw)
12274 !
12275 ! This subroutine calculates the interaction energy of nonbonded side chains
12276 ! assuming the LJK potential of interaction.
12277 !
12278 !      implicit real*8 (a-h,o-z)
12279 !      include 'DIMENSIONS'
12280 !      include 'COMMON.GEO'
12281 !      include 'COMMON.VAR'
12282 !      include 'COMMON.LOCAL'
12283 !      include 'COMMON.CHAIN'
12284 !      include 'COMMON.DERIV'
12285 !      include 'COMMON.INTERACT'
12286 !      include 'COMMON.IOUNITS'
12287 !      include 'COMMON.NAMES'
12288       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12289       logical :: scheck
12290 !el local variables
12291       integer :: i,iint,j,k,itypi,itypi1,itypj
12292       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12293                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12294 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12295       evdw=0.0D0
12296       do i=iatsc_s,iatsc_e
12297         itypi=itype(i)
12298         if (itypi.eq.ntyp1) cycle
12299         itypi1=itype(i+1)
12300         xi=c(1,nres+i)
12301         yi=c(2,nres+i)
12302         zi=c(3,nres+i)
12303 !
12304 ! Calculate SC interaction energy.
12305 !
12306         do iint=1,nint_gr(i)
12307           do j=istart(i,iint),iend(i,iint)
12308             itypj=itype(j)
12309             if (itypj.eq.ntyp1) cycle
12310             xj=c(1,nres+j)-xi
12311             yj=c(2,nres+j)-yi
12312             zj=c(3,nres+j)-zi
12313             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12314             fac_augm=rrij**expon
12315             e_augm=augm(itypi,itypj)*fac_augm
12316             r_inv_ij=dsqrt(rrij)
12317             rij=1.0D0/r_inv_ij
12318             sss=sscale(rij/sigma(itypi,itypj))
12319             if (sss.gt.0.0d0) then
12320               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12321               fac=r_shift_inv**expon
12322               e1=fac*fac*aa_aq(itypi,itypj)
12323               e2=fac*bb_aq(itypi,itypj)
12324               evdwij=e_augm+e1+e2
12325 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12326 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12327 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12328 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
12329 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12330 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12331 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12332               evdw=evdw+sss*evdwij
12333 !
12334 ! Calculate the components of the gradient in DC and X
12335 !
12336               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12337               fac=fac*sss
12338               gg(1)=xj*fac
12339               gg(2)=yj*fac
12340               gg(3)=zj*fac
12341               do k=1,3
12342                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12343                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12344                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12345                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12346               enddo
12347             endif
12348           enddo      ! j
12349         enddo        ! iint
12350       enddo          ! i
12351       do i=1,nct
12352         do j=1,3
12353           gvdwc(j,i)=expon*gvdwc(j,i)
12354           gvdwx(j,i)=expon*gvdwx(j,i)
12355         enddo
12356       enddo
12357       return
12358       end subroutine eljk_short
12359 !-----------------------------------------------------------------------------
12360       subroutine ebp_long(evdw)
12361 !
12362 ! This subroutine calculates the interaction energy of nonbonded side chains
12363 ! assuming the Berne-Pechukas potential of interaction.
12364 !
12365       use calc_data
12366 !      implicit real*8 (a-h,o-z)
12367 !      include 'DIMENSIONS'
12368 !      include 'COMMON.GEO'
12369 !      include 'COMMON.VAR'
12370 !      include 'COMMON.LOCAL'
12371 !      include 'COMMON.CHAIN'
12372 !      include 'COMMON.DERIV'
12373 !      include 'COMMON.NAMES'
12374 !      include 'COMMON.INTERACT'
12375 !      include 'COMMON.IOUNITS'
12376 !      include 'COMMON.CALC'
12377       use comm_srutu
12378 !el      integer :: icall
12379 !el      common /srutu/ icall
12380 !     double precision rrsave(maxdim)
12381       logical :: lprn
12382 !el local variables
12383       integer :: iint,itypi,itypi1,itypj
12384       real(kind=8) :: rrij,xi,yi,zi,fac
12385       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12386       evdw=0.0D0
12387 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12388       evdw=0.0D0
12389 !     if (icall.eq.0) then
12390 !       lprn=.true.
12391 !     else
12392         lprn=.false.
12393 !     endif
12394 !el      ind=0
12395       do i=iatsc_s,iatsc_e
12396         itypi=itype(i)
12397         if (itypi.eq.ntyp1) cycle
12398         itypi1=itype(i+1)
12399         xi=c(1,nres+i)
12400         yi=c(2,nres+i)
12401         zi=c(3,nres+i)
12402         dxi=dc_norm(1,nres+i)
12403         dyi=dc_norm(2,nres+i)
12404         dzi=dc_norm(3,nres+i)
12405 !        dsci_inv=dsc_inv(itypi)
12406         dsci_inv=vbld_inv(i+nres)
12407 !
12408 ! Calculate SC interaction energy.
12409 !
12410         do iint=1,nint_gr(i)
12411           do j=istart(i,iint),iend(i,iint)
12412 !el            ind=ind+1
12413             itypj=itype(j)
12414             if (itypj.eq.ntyp1) cycle
12415 !            dscj_inv=dsc_inv(itypj)
12416             dscj_inv=vbld_inv(j+nres)
12417             chi1=chi(itypi,itypj)
12418             chi2=chi(itypj,itypi)
12419             chi12=chi1*chi2
12420             chip1=chip(itypi)
12421             chip2=chip(itypj)
12422             chip12=chip1*chip2
12423             alf1=alp(itypi)
12424             alf2=alp(itypj)
12425             alf12=0.5D0*(alf1+alf2)
12426             xj=c(1,nres+j)-xi
12427             yj=c(2,nres+j)-yi
12428             zj=c(3,nres+j)-zi
12429             dxj=dc_norm(1,nres+j)
12430             dyj=dc_norm(2,nres+j)
12431             dzj=dc_norm(3,nres+j)
12432             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12433             rij=dsqrt(rrij)
12434             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12435
12436             if (sss.lt.1.0d0) then
12437
12438 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12439               call sc_angular
12440 ! Calculate whole angle-dependent part of epsilon and contributions
12441 ! to its derivatives
12442               fac=(rrij*sigsq)**expon2
12443               e1=fac*fac*aa_aq(itypi,itypj)
12444               e2=fac*bb_aq(itypi,itypj)
12445               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12446               eps2der=evdwij*eps3rt
12447               eps3der=evdwij*eps2rt
12448               evdwij=evdwij*eps2rt*eps3rt
12449               evdw=evdw+evdwij*(1.0d0-sss)
12450               if (lprn) then
12451               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12452               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12453 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12454 !d     &          restyp(itypi),i,restyp(itypj),j,
12455 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12456 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12457 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12458 !d     &          evdwij
12459               endif
12460 ! Calculate gradient components.
12461               e1=e1*eps1*eps2rt**2*eps3rt**2
12462               fac=-expon*(e1+evdwij)
12463               sigder=fac/sigsq
12464               fac=rrij*fac
12465 ! Calculate radial part of the gradient
12466               gg(1)=xj*fac
12467               gg(2)=yj*fac
12468               gg(3)=zj*fac
12469 ! Calculate the angular part of the gradient and sum add the contributions
12470 ! to the appropriate components of the Cartesian gradient.
12471               call sc_grad_scale(1.0d0-sss)
12472             endif
12473           enddo      ! j
12474         enddo        ! iint
12475       enddo          ! i
12476 !     stop
12477       return
12478       end subroutine ebp_long
12479 !-----------------------------------------------------------------------------
12480       subroutine ebp_short(evdw)
12481 !
12482 ! This subroutine calculates the interaction energy of nonbonded side chains
12483 ! assuming the Berne-Pechukas potential of interaction.
12484 !
12485       use calc_data
12486 !      implicit real*8 (a-h,o-z)
12487 !      include 'DIMENSIONS'
12488 !      include 'COMMON.GEO'
12489 !      include 'COMMON.VAR'
12490 !      include 'COMMON.LOCAL'
12491 !      include 'COMMON.CHAIN'
12492 !      include 'COMMON.DERIV'
12493 !      include 'COMMON.NAMES'
12494 !      include 'COMMON.INTERACT'
12495 !      include 'COMMON.IOUNITS'
12496 !      include 'COMMON.CALC'
12497       use comm_srutu
12498 !el      integer :: icall
12499 !el      common /srutu/ icall
12500 !     double precision rrsave(maxdim)
12501       logical :: lprn
12502 !el local variables
12503       integer :: iint,itypi,itypi1,itypj
12504       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12505       real(kind=8) :: sss,e1,e2,evdw
12506       evdw=0.0D0
12507 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12508       evdw=0.0D0
12509 !     if (icall.eq.0) then
12510 !       lprn=.true.
12511 !     else
12512         lprn=.false.
12513 !     endif
12514 !el      ind=0
12515       do i=iatsc_s,iatsc_e
12516         itypi=itype(i)
12517         if (itypi.eq.ntyp1) cycle
12518         itypi1=itype(i+1)
12519         xi=c(1,nres+i)
12520         yi=c(2,nres+i)
12521         zi=c(3,nres+i)
12522         dxi=dc_norm(1,nres+i)
12523         dyi=dc_norm(2,nres+i)
12524         dzi=dc_norm(3,nres+i)
12525 !        dsci_inv=dsc_inv(itypi)
12526         dsci_inv=vbld_inv(i+nres)
12527 !
12528 ! Calculate SC interaction energy.
12529 !
12530         do iint=1,nint_gr(i)
12531           do j=istart(i,iint),iend(i,iint)
12532 !el            ind=ind+1
12533             itypj=itype(j)
12534             if (itypj.eq.ntyp1) cycle
12535 !            dscj_inv=dsc_inv(itypj)
12536             dscj_inv=vbld_inv(j+nres)
12537             chi1=chi(itypi,itypj)
12538             chi2=chi(itypj,itypi)
12539             chi12=chi1*chi2
12540             chip1=chip(itypi)
12541             chip2=chip(itypj)
12542             chip12=chip1*chip2
12543             alf1=alp(itypi)
12544             alf2=alp(itypj)
12545             alf12=0.5D0*(alf1+alf2)
12546             xj=c(1,nres+j)-xi
12547             yj=c(2,nres+j)-yi
12548             zj=c(3,nres+j)-zi
12549             dxj=dc_norm(1,nres+j)
12550             dyj=dc_norm(2,nres+j)
12551             dzj=dc_norm(3,nres+j)
12552             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12553             rij=dsqrt(rrij)
12554             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12555
12556             if (sss.gt.0.0d0) then
12557
12558 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12559               call sc_angular
12560 ! Calculate whole angle-dependent part of epsilon and contributions
12561 ! to its derivatives
12562               fac=(rrij*sigsq)**expon2
12563               e1=fac*fac*aa_aq(itypi,itypj)
12564               e2=fac*bb_aq(itypi,itypj)
12565               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12566               eps2der=evdwij*eps3rt
12567               eps3der=evdwij*eps2rt
12568               evdwij=evdwij*eps2rt*eps3rt
12569               evdw=evdw+evdwij*sss
12570               if (lprn) then
12571               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12572               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12573 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12574 !d     &          restyp(itypi),i,restyp(itypj),j,
12575 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12576 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12577 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12578 !d     &          evdwij
12579               endif
12580 ! Calculate gradient components.
12581               e1=e1*eps1*eps2rt**2*eps3rt**2
12582               fac=-expon*(e1+evdwij)
12583               sigder=fac/sigsq
12584               fac=rrij*fac
12585 ! Calculate radial part of the gradient
12586               gg(1)=xj*fac
12587               gg(2)=yj*fac
12588               gg(3)=zj*fac
12589 ! Calculate the angular part of the gradient and sum add the contributions
12590 ! to the appropriate components of the Cartesian gradient.
12591               call sc_grad_scale(sss)
12592             endif
12593           enddo      ! j
12594         enddo        ! iint
12595       enddo          ! i
12596 !     stop
12597       return
12598       end subroutine ebp_short
12599 !-----------------------------------------------------------------------------
12600       subroutine egb_long(evdw)
12601 !
12602 ! This subroutine calculates the interaction energy of nonbonded side chains
12603 ! assuming the Gay-Berne potential of interaction.
12604 !
12605       use calc_data
12606 !      implicit real*8 (a-h,o-z)
12607 !      include 'DIMENSIONS'
12608 !      include 'COMMON.GEO'
12609 !      include 'COMMON.VAR'
12610 !      include 'COMMON.LOCAL'
12611 !      include 'COMMON.CHAIN'
12612 !      include 'COMMON.DERIV'
12613 !      include 'COMMON.NAMES'
12614 !      include 'COMMON.INTERACT'
12615 !      include 'COMMON.IOUNITS'
12616 !      include 'COMMON.CALC'
12617 !      include 'COMMON.CONTROL'
12618       logical :: lprn
12619 !el local variables
12620       integer :: iint,itypi,itypi1,itypj,subchap
12621       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
12622       real(kind=8) :: sss,e1,e2,evdw,sss_grad
12623       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
12624                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
12625                     ssgradlipi,ssgradlipj
12626
12627
12628       evdw=0.0D0
12629 !cccc      energy_dec=.false.
12630 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12631       evdw=0.0D0
12632       lprn=.false.
12633 !     if (icall.eq.0) lprn=.false.
12634 !el      ind=0
12635       do i=iatsc_s,iatsc_e
12636         itypi=itype(i)
12637         if (itypi.eq.ntyp1) cycle
12638         itypi1=itype(i+1)
12639         xi=c(1,nres+i)
12640         yi=c(2,nres+i)
12641         zi=c(3,nres+i)
12642           xi=mod(xi,boxxsize)
12643           if (xi.lt.0) xi=xi+boxxsize
12644           yi=mod(yi,boxysize)
12645           if (yi.lt.0) yi=yi+boxysize
12646           zi=mod(zi,boxzsize)
12647           if (zi.lt.0) zi=zi+boxzsize
12648        if ((zi.gt.bordlipbot)    &
12649         .and.(zi.lt.bordliptop)) then
12650 !C the energy transfer exist
12651         if (zi.lt.buflipbot) then
12652 !C what fraction I am in
12653          fracinbuf=1.0d0-    &
12654              ((zi-bordlipbot)/lipbufthick)
12655 !C lipbufthick is thickenes of lipid buffore
12656          sslipi=sscalelip(fracinbuf)
12657          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
12658         elseif (zi.gt.bufliptop) then
12659          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
12660          sslipi=sscalelip(fracinbuf)
12661          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
12662         else
12663          sslipi=1.0d0
12664          ssgradlipi=0.0
12665         endif
12666        else
12667          sslipi=0.0d0
12668          ssgradlipi=0.0
12669        endif
12670
12671         dxi=dc_norm(1,nres+i)
12672         dyi=dc_norm(2,nres+i)
12673         dzi=dc_norm(3,nres+i)
12674 !        dsci_inv=dsc_inv(itypi)
12675         dsci_inv=vbld_inv(i+nres)
12676 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
12677 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
12678 !
12679 ! Calculate SC interaction energy.
12680 !
12681         do iint=1,nint_gr(i)
12682           do j=istart(i,iint),iend(i,iint)
12683             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
12684               call dyn_ssbond_ene(i,j,evdwij)
12685               evdw=evdw+evdwij
12686               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12687                               'evdw',i,j,evdwij,' ss'
12688 !              if (energy_dec) write (iout,*) &
12689 !                              'evdw',i,j,evdwij,' ss'
12690             ELSE
12691 !el            ind=ind+1
12692             itypj=itype(j)
12693             if (itypj.eq.ntyp1) cycle
12694 !            dscj_inv=dsc_inv(itypj)
12695             dscj_inv=vbld_inv(j+nres)
12696 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
12697 !     &       1.0d0/vbld(j+nres)
12698 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
12699             sig0ij=sigma(itypi,itypj)
12700             chi1=chi(itypi,itypj)
12701             chi2=chi(itypj,itypi)
12702             chi12=chi1*chi2
12703             chip1=chip(itypi)
12704             chip2=chip(itypj)
12705             chip12=chip1*chip2
12706             alf1=alp(itypi)
12707             alf2=alp(itypj)
12708             alf12=0.5D0*(alf1+alf2)
12709             xj=c(1,nres+j)
12710             yj=c(2,nres+j)
12711             zj=c(3,nres+j)
12712 ! Searching for nearest neighbour
12713           xj=mod(xj,boxxsize)
12714           if (xj.lt.0) xj=xj+boxxsize
12715           yj=mod(yj,boxysize)
12716           if (yj.lt.0) yj=yj+boxysize
12717           zj=mod(zj,boxzsize)
12718           if (zj.lt.0) zj=zj+boxzsize
12719        if ((zj.gt.bordlipbot)   &
12720       .and.(zj.lt.bordliptop)) then
12721 !C the energy transfer exist
12722         if (zj.lt.buflipbot) then
12723 !C what fraction I am in
12724          fracinbuf=1.0d0-  &
12725              ((zj-bordlipbot)/lipbufthick)
12726 !C lipbufthick is thickenes of lipid buffore
12727          sslipj=sscalelip(fracinbuf)
12728          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
12729         elseif (zj.gt.bufliptop) then
12730          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
12731          sslipj=sscalelip(fracinbuf)
12732          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
12733         else
12734          sslipj=1.0d0
12735          ssgradlipj=0.0
12736         endif
12737        else
12738          sslipj=0.0d0
12739          ssgradlipj=0.0
12740        endif
12741       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12742        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12743       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12744        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12745
12746           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12747           xj_safe=xj
12748           yj_safe=yj
12749           zj_safe=zj
12750           subchap=0
12751           do xshift=-1,1
12752           do yshift=-1,1
12753           do zshift=-1,1
12754           xj=xj_safe+xshift*boxxsize
12755           yj=yj_safe+yshift*boxysize
12756           zj=zj_safe+zshift*boxzsize
12757           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12758           if(dist_temp.lt.dist_init) then
12759             dist_init=dist_temp
12760             xj_temp=xj
12761             yj_temp=yj
12762             zj_temp=zj
12763             subchap=1
12764           endif
12765           enddo
12766           enddo
12767           enddo
12768           if (subchap.eq.1) then
12769           xj=xj_temp-xi
12770           yj=yj_temp-yi
12771           zj=zj_temp-zi
12772           else
12773           xj=xj_safe-xi
12774           yj=yj_safe-yi
12775           zj=zj_safe-zi
12776           endif
12777
12778             dxj=dc_norm(1,nres+j)
12779             dyj=dc_norm(2,nres+j)
12780             dzj=dc_norm(3,nres+j)
12781             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12782             rij=dsqrt(rrij)
12783             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12784             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
12785             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
12786             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
12787             if (sss_ele_cut.le.0.0) cycle
12788             if (sss.lt.1.0d0) then
12789
12790 ! Calculate angle-dependent terms of energy and contributions to their
12791 ! derivatives.
12792               call sc_angular
12793               sigsq=1.0D0/sigsq
12794               sig=sig0ij*dsqrt(sigsq)
12795               rij_shift=1.0D0/rij-sig+sig0ij
12796 ! for diagnostics; uncomment
12797 !              rij_shift=1.2*sig0ij
12798 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12799               if (rij_shift.le.0.0D0) then
12800                 evdw=1.0D20
12801 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
12802 !d     &          restyp(itypi),i,restyp(itypj),j,
12803 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
12804                 return
12805               endif
12806               sigder=-sig*sigsq
12807 !---------------------------------------------------------------
12808               rij_shift=1.0D0/rij_shift
12809               fac=rij_shift**expon
12810               e1=fac*fac*aa
12811               e2=fac*bb
12812               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12813               eps2der=evdwij*eps3rt
12814               eps3der=evdwij*eps2rt
12815 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
12816 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
12817               evdwij=evdwij*eps2rt*eps3rt
12818               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
12819               if (lprn) then
12820               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12821               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12822               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12823                 restyp(itypi),i,restyp(itypj),j,&
12824                 epsi,sigm,chi1,chi2,chip1,chip2,&
12825                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
12826                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12827                 evdwij
12828               endif
12829
12830               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12831                               'evdw',i,j,evdwij
12832 !              if (energy_dec) write (iout,*) &
12833 !                              'evdw',i,j,evdwij,"egb_long"
12834
12835 ! Calculate gradient components.
12836               e1=e1*eps1*eps2rt**2*eps3rt**2
12837               fac=-expon*(e1+evdwij)*rij_shift
12838               sigder=fac*sigder
12839               fac=rij*fac
12840               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
12841             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
12842             /sigmaii(itypi,itypj))
12843 !              fac=0.0d0
12844 ! Calculate the radial part of the gradient
12845               gg(1)=xj*fac
12846               gg(2)=yj*fac
12847               gg(3)=zj*fac
12848 ! Calculate angular part of the gradient.
12849               call sc_grad_scale(1.0d0-sss)
12850             ENDIF    !mask_dyn_ss
12851             endif
12852           enddo      ! j
12853         enddo        ! iint
12854       enddo          ! i
12855 !      write (iout,*) "Number of loop steps in EGB:",ind
12856 !ccc      energy_dec=.false.
12857       return
12858       end subroutine egb_long
12859 !-----------------------------------------------------------------------------
12860       subroutine egb_short(evdw)
12861 !
12862 ! This subroutine calculates the interaction energy of nonbonded side chains
12863 ! assuming the Gay-Berne potential of interaction.
12864 !
12865       use calc_data
12866 !      implicit real*8 (a-h,o-z)
12867 !      include 'DIMENSIONS'
12868 !      include 'COMMON.GEO'
12869 !      include 'COMMON.VAR'
12870 !      include 'COMMON.LOCAL'
12871 !      include 'COMMON.CHAIN'
12872 !      include 'COMMON.DERIV'
12873 !      include 'COMMON.NAMES'
12874 !      include 'COMMON.INTERACT'
12875 !      include 'COMMON.IOUNITS'
12876 !      include 'COMMON.CALC'
12877 !      include 'COMMON.CONTROL'
12878       logical :: lprn
12879 !el local variables
12880       integer :: iint,itypi,itypi1,itypj,subchap
12881       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
12882       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
12883       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
12884                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
12885                     ssgradlipi,ssgradlipj
12886       evdw=0.0D0
12887 !cccc      energy_dec=.false.
12888 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12889       evdw=0.0D0
12890       lprn=.false.
12891 !     if (icall.eq.0) lprn=.false.
12892 !el      ind=0
12893       do i=iatsc_s,iatsc_e
12894         itypi=itype(i)
12895         if (itypi.eq.ntyp1) cycle
12896         itypi1=itype(i+1)
12897         xi=c(1,nres+i)
12898         yi=c(2,nres+i)
12899         zi=c(3,nres+i)
12900           xi=mod(xi,boxxsize)
12901           if (xi.lt.0) xi=xi+boxxsize
12902           yi=mod(yi,boxysize)
12903           if (yi.lt.0) yi=yi+boxysize
12904           zi=mod(zi,boxzsize)
12905           if (zi.lt.0) zi=zi+boxzsize
12906        if ((zi.gt.bordlipbot)    &
12907         .and.(zi.lt.bordliptop)) then
12908 !C the energy transfer exist
12909         if (zi.lt.buflipbot) then
12910 !C what fraction I am in
12911          fracinbuf=1.0d0-    &
12912              ((zi-bordlipbot)/lipbufthick)
12913 !C lipbufthick is thickenes of lipid buffore
12914          sslipi=sscalelip(fracinbuf)
12915          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
12916         elseif (zi.gt.bufliptop) then
12917          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
12918          sslipi=sscalelip(fracinbuf)
12919          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
12920         else
12921          sslipi=1.0d0
12922          ssgradlipi=0.0
12923         endif
12924        else
12925          sslipi=0.0d0
12926          ssgradlipi=0.0
12927        endif
12928
12929         dxi=dc_norm(1,nres+i)
12930         dyi=dc_norm(2,nres+i)
12931         dzi=dc_norm(3,nres+i)
12932 !        dsci_inv=dsc_inv(itypi)
12933         dsci_inv=vbld_inv(i+nres)
12934
12935         dxi=dc_norm(1,nres+i)
12936         dyi=dc_norm(2,nres+i)
12937         dzi=dc_norm(3,nres+i)
12938 !        dsci_inv=dsc_inv(itypi)
12939         dsci_inv=vbld_inv(i+nres)
12940 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
12941 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
12942 !
12943 ! Calculate SC interaction energy.
12944 !
12945         do iint=1,nint_gr(i)
12946           do j=istart(i,iint),iend(i,iint)
12947             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
12948               call dyn_ssbond_ene(i,j,evdwij)
12949               evdw=evdw+evdwij
12950               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12951                               'evdw',i,j,evdwij,' ss'
12952 !              if (energy_dec) write (iout,*) &
12953 !                              'evdw',i,j,evdwij,' ss'
12954             ELSE
12955 !el            ind=ind+1
12956             itypj=itype(j)
12957             if (itypj.eq.ntyp1) cycle
12958 !            dscj_inv=dsc_inv(itypj)
12959             dscj_inv=vbld_inv(j+nres)
12960 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
12961 !     &       1.0d0/vbld(j+nres)
12962 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
12963             sig0ij=sigma(itypi,itypj)
12964             chi1=chi(itypi,itypj)
12965             chi2=chi(itypj,itypi)
12966             chi12=chi1*chi2
12967             chip1=chip(itypi)
12968             chip2=chip(itypj)
12969             chip12=chip1*chip2
12970             alf1=alp(itypi)
12971             alf2=alp(itypj)
12972             alf12=0.5D0*(alf1+alf2)
12973 !            xj=c(1,nres+j)-xi
12974 !            yj=c(2,nres+j)-yi
12975 !            zj=c(3,nres+j)-zi
12976             xj=c(1,nres+j)
12977             yj=c(2,nres+j)
12978             zj=c(3,nres+j)
12979 ! Searching for nearest neighbour
12980           xj=mod(xj,boxxsize)
12981           if (xj.lt.0) xj=xj+boxxsize
12982           yj=mod(yj,boxysize)
12983           if (yj.lt.0) yj=yj+boxysize
12984           zj=mod(zj,boxzsize)
12985           if (zj.lt.0) zj=zj+boxzsize
12986        if ((zj.gt.bordlipbot)   &
12987       .and.(zj.lt.bordliptop)) then
12988 !C the energy transfer exist
12989         if (zj.lt.buflipbot) then
12990 !C what fraction I am in
12991          fracinbuf=1.0d0-  &
12992              ((zj-bordlipbot)/lipbufthick)
12993 !C lipbufthick is thickenes of lipid buffore
12994          sslipj=sscalelip(fracinbuf)
12995          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
12996         elseif (zj.gt.bufliptop) then
12997          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
12998          sslipj=sscalelip(fracinbuf)
12999          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13000         else
13001          sslipj=1.0d0
13002          ssgradlipj=0.0
13003         endif
13004        else
13005          sslipj=0.0d0
13006          ssgradlipj=0.0
13007        endif
13008       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13009        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13010       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13011        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13012
13013           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13014           xj_safe=xj
13015           yj_safe=yj
13016           zj_safe=zj
13017           subchap=0
13018
13019           do xshift=-1,1
13020           do yshift=-1,1
13021           do zshift=-1,1
13022           xj=xj_safe+xshift*boxxsize
13023           yj=yj_safe+yshift*boxysize
13024           zj=zj_safe+zshift*boxzsize
13025           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13026           if(dist_temp.lt.dist_init) then
13027             dist_init=dist_temp
13028             xj_temp=xj
13029             yj_temp=yj
13030             zj_temp=zj
13031             subchap=1
13032           endif
13033           enddo
13034           enddo
13035           enddo
13036           if (subchap.eq.1) then
13037           xj=xj_temp-xi
13038           yj=yj_temp-yi
13039           zj=zj_temp-zi
13040           else
13041           xj=xj_safe-xi
13042           yj=yj_safe-yi
13043           zj=zj_safe-zi
13044           endif
13045
13046             dxj=dc_norm(1,nres+j)
13047             dyj=dc_norm(2,nres+j)
13048             dzj=dc_norm(3,nres+j)
13049             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13050             rij=dsqrt(rrij)
13051             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13052             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13053             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13054             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13055             if (sss_ele_cut.le.0.0) cycle
13056
13057             if (sss.gt.0.0d0) then
13058
13059 ! Calculate angle-dependent terms of energy and contributions to their
13060 ! derivatives.
13061               call sc_angular
13062               sigsq=1.0D0/sigsq
13063               sig=sig0ij*dsqrt(sigsq)
13064               rij_shift=1.0D0/rij-sig+sig0ij
13065 ! for diagnostics; uncomment
13066 !              rij_shift=1.2*sig0ij
13067 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13068               if (rij_shift.le.0.0D0) then
13069                 evdw=1.0D20
13070 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13071 !d     &          restyp(itypi),i,restyp(itypj),j,
13072 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13073                 return
13074               endif
13075               sigder=-sig*sigsq
13076 !---------------------------------------------------------------
13077               rij_shift=1.0D0/rij_shift
13078               fac=rij_shift**expon
13079               e1=fac*fac*aa
13080               e2=fac*bb
13081               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13082               eps2der=evdwij*eps3rt
13083               eps3der=evdwij*eps2rt
13084 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13085 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13086               evdwij=evdwij*eps2rt*eps3rt
13087               evdw=evdw+evdwij*sss*sss_ele_cut
13088               if (lprn) then
13089               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13090               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13091               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13092                 restyp(itypi),i,restyp(itypj),j,&
13093                 epsi,sigm,chi1,chi2,chip1,chip2,&
13094                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13095                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13096                 evdwij
13097               endif
13098
13099               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13100                               'evdw',i,j,evdwij
13101 !              if (energy_dec) write (iout,*) &
13102 !                              'evdw',i,j,evdwij,"egb_short"
13103
13104 ! Calculate gradient components.
13105               e1=e1*eps1*eps2rt**2*eps3rt**2
13106               fac=-expon*(e1+evdwij)*rij_shift
13107               sigder=fac*sigder
13108               fac=rij*fac
13109               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13110             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13111             /sigmaii(itypi,itypj))
13112
13113 !              fac=0.0d0
13114 ! Calculate the radial part of the gradient
13115               gg(1)=xj*fac
13116               gg(2)=yj*fac
13117               gg(3)=zj*fac
13118 ! Calculate angular part of the gradient.
13119               call sc_grad_scale(sss)
13120             endif
13121           ENDIF !mask_dyn_ss
13122           enddo      ! j
13123         enddo        ! iint
13124       enddo          ! i
13125 !      write (iout,*) "Number of loop steps in EGB:",ind
13126 !ccc      energy_dec=.false.
13127       return
13128       end subroutine egb_short
13129 !-----------------------------------------------------------------------------
13130       subroutine egbv_long(evdw)
13131 !
13132 ! This subroutine calculates the interaction energy of nonbonded side chains
13133 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13134 !
13135       use calc_data
13136 !      implicit real*8 (a-h,o-z)
13137 !      include 'DIMENSIONS'
13138 !      include 'COMMON.GEO'
13139 !      include 'COMMON.VAR'
13140 !      include 'COMMON.LOCAL'
13141 !      include 'COMMON.CHAIN'
13142 !      include 'COMMON.DERIV'
13143 !      include 'COMMON.NAMES'
13144 !      include 'COMMON.INTERACT'
13145 !      include 'COMMON.IOUNITS'
13146 !      include 'COMMON.CALC'
13147       use comm_srutu
13148 !el      integer :: icall
13149 !el      common /srutu/ icall
13150       logical :: lprn
13151 !el local variables
13152       integer :: iint,itypi,itypi1,itypj
13153       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13154       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13155       evdw=0.0D0
13156 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13157       evdw=0.0D0
13158       lprn=.false.
13159 !     if (icall.eq.0) lprn=.true.
13160 !el      ind=0
13161       do i=iatsc_s,iatsc_e
13162         itypi=itype(i)
13163         if (itypi.eq.ntyp1) cycle
13164         itypi1=itype(i+1)
13165         xi=c(1,nres+i)
13166         yi=c(2,nres+i)
13167         zi=c(3,nres+i)
13168         dxi=dc_norm(1,nres+i)
13169         dyi=dc_norm(2,nres+i)
13170         dzi=dc_norm(3,nres+i)
13171 !        dsci_inv=dsc_inv(itypi)
13172         dsci_inv=vbld_inv(i+nres)
13173 !
13174 ! Calculate SC interaction energy.
13175 !
13176         do iint=1,nint_gr(i)
13177           do j=istart(i,iint),iend(i,iint)
13178 !el            ind=ind+1
13179             itypj=itype(j)
13180             if (itypj.eq.ntyp1) cycle
13181 !            dscj_inv=dsc_inv(itypj)
13182             dscj_inv=vbld_inv(j+nres)
13183             sig0ij=sigma(itypi,itypj)
13184             r0ij=r0(itypi,itypj)
13185             chi1=chi(itypi,itypj)
13186             chi2=chi(itypj,itypi)
13187             chi12=chi1*chi2
13188             chip1=chip(itypi)
13189             chip2=chip(itypj)
13190             chip12=chip1*chip2
13191             alf1=alp(itypi)
13192             alf2=alp(itypj)
13193             alf12=0.5D0*(alf1+alf2)
13194             xj=c(1,nres+j)-xi
13195             yj=c(2,nres+j)-yi
13196             zj=c(3,nres+j)-zi
13197             dxj=dc_norm(1,nres+j)
13198             dyj=dc_norm(2,nres+j)
13199             dzj=dc_norm(3,nres+j)
13200             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13201             rij=dsqrt(rrij)
13202
13203             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13204
13205             if (sss.lt.1.0d0) then
13206
13207 ! Calculate angle-dependent terms of energy and contributions to their
13208 ! derivatives.
13209               call sc_angular
13210               sigsq=1.0D0/sigsq
13211               sig=sig0ij*dsqrt(sigsq)
13212               rij_shift=1.0D0/rij-sig+r0ij
13213 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13214               if (rij_shift.le.0.0D0) then
13215                 evdw=1.0D20
13216                 return
13217               endif
13218               sigder=-sig*sigsq
13219 !---------------------------------------------------------------
13220               rij_shift=1.0D0/rij_shift
13221               fac=rij_shift**expon
13222               e1=fac*fac*aa_aq(itypi,itypj)
13223               e2=fac*bb_aq(itypi,itypj)
13224               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13225               eps2der=evdwij*eps3rt
13226               eps3der=evdwij*eps2rt
13227               fac_augm=rrij**expon
13228               e_augm=augm(itypi,itypj)*fac_augm
13229               evdwij=evdwij*eps2rt*eps3rt
13230               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13231               if (lprn) then
13232               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13233               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13234               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13235                 restyp(itypi),i,restyp(itypj),j,&
13236                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13237                 chi1,chi2,chip1,chip2,&
13238                 eps1,eps2rt**2,eps3rt**2,&
13239                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13240                 evdwij+e_augm
13241               endif
13242 ! Calculate gradient components.
13243               e1=e1*eps1*eps2rt**2*eps3rt**2
13244               fac=-expon*(e1+evdwij)*rij_shift
13245               sigder=fac*sigder
13246               fac=rij*fac-2*expon*rrij*e_augm
13247 ! Calculate the radial part of the gradient
13248               gg(1)=xj*fac
13249               gg(2)=yj*fac
13250               gg(3)=zj*fac
13251 ! Calculate angular part of the gradient.
13252               call sc_grad_scale(1.0d0-sss)
13253             endif
13254           enddo      ! j
13255         enddo        ! iint
13256       enddo          ! i
13257       end subroutine egbv_long
13258 !-----------------------------------------------------------------------------
13259       subroutine egbv_short(evdw)
13260 !
13261 ! This subroutine calculates the interaction energy of nonbonded side chains
13262 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13263 !
13264       use calc_data
13265 !      implicit real*8 (a-h,o-z)
13266 !      include 'DIMENSIONS'
13267 !      include 'COMMON.GEO'
13268 !      include 'COMMON.VAR'
13269 !      include 'COMMON.LOCAL'
13270 !      include 'COMMON.CHAIN'
13271 !      include 'COMMON.DERIV'
13272 !      include 'COMMON.NAMES'
13273 !      include 'COMMON.INTERACT'
13274 !      include 'COMMON.IOUNITS'
13275 !      include 'COMMON.CALC'
13276       use comm_srutu
13277 !el      integer :: icall
13278 !el      common /srutu/ icall
13279       logical :: lprn
13280 !el local variables
13281       integer :: iint,itypi,itypi1,itypj
13282       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13283       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13284       evdw=0.0D0
13285 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13286       evdw=0.0D0
13287       lprn=.false.
13288 !     if (icall.eq.0) lprn=.true.
13289 !el      ind=0
13290       do i=iatsc_s,iatsc_e
13291         itypi=itype(i)
13292         if (itypi.eq.ntyp1) cycle
13293         itypi1=itype(i+1)
13294         xi=c(1,nres+i)
13295         yi=c(2,nres+i)
13296         zi=c(3,nres+i)
13297         dxi=dc_norm(1,nres+i)
13298         dyi=dc_norm(2,nres+i)
13299         dzi=dc_norm(3,nres+i)
13300 !        dsci_inv=dsc_inv(itypi)
13301         dsci_inv=vbld_inv(i+nres)
13302 !
13303 ! Calculate SC interaction energy.
13304 !
13305         do iint=1,nint_gr(i)
13306           do j=istart(i,iint),iend(i,iint)
13307 !el            ind=ind+1
13308             itypj=itype(j)
13309             if (itypj.eq.ntyp1) cycle
13310 !            dscj_inv=dsc_inv(itypj)
13311             dscj_inv=vbld_inv(j+nres)
13312             sig0ij=sigma(itypi,itypj)
13313             r0ij=r0(itypi,itypj)
13314             chi1=chi(itypi,itypj)
13315             chi2=chi(itypj,itypi)
13316             chi12=chi1*chi2
13317             chip1=chip(itypi)
13318             chip2=chip(itypj)
13319             chip12=chip1*chip2
13320             alf1=alp(itypi)
13321             alf2=alp(itypj)
13322             alf12=0.5D0*(alf1+alf2)
13323             xj=c(1,nres+j)-xi
13324             yj=c(2,nres+j)-yi
13325             zj=c(3,nres+j)-zi
13326             dxj=dc_norm(1,nres+j)
13327             dyj=dc_norm(2,nres+j)
13328             dzj=dc_norm(3,nres+j)
13329             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13330             rij=dsqrt(rrij)
13331
13332             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13333
13334             if (sss.gt.0.0d0) then
13335
13336 ! Calculate angle-dependent terms of energy and contributions to their
13337 ! derivatives.
13338               call sc_angular
13339               sigsq=1.0D0/sigsq
13340               sig=sig0ij*dsqrt(sigsq)
13341               rij_shift=1.0D0/rij-sig+r0ij
13342 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13343               if (rij_shift.le.0.0D0) then
13344                 evdw=1.0D20
13345                 return
13346               endif
13347               sigder=-sig*sigsq
13348 !---------------------------------------------------------------
13349               rij_shift=1.0D0/rij_shift
13350               fac=rij_shift**expon
13351               e1=fac*fac*aa_aq(itypi,itypj)
13352               e2=fac*bb_aq(itypi,itypj)
13353               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13354               eps2der=evdwij*eps3rt
13355               eps3der=evdwij*eps2rt
13356               fac_augm=rrij**expon
13357               e_augm=augm(itypi,itypj)*fac_augm
13358               evdwij=evdwij*eps2rt*eps3rt
13359               evdw=evdw+(evdwij+e_augm)*sss
13360               if (lprn) then
13361               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13362               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13363               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13364                 restyp(itypi),i,restyp(itypj),j,&
13365                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13366                 chi1,chi2,chip1,chip2,&
13367                 eps1,eps2rt**2,eps3rt**2,&
13368                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13369                 evdwij+e_augm
13370               endif
13371 ! Calculate gradient components.
13372               e1=e1*eps1*eps2rt**2*eps3rt**2
13373               fac=-expon*(e1+evdwij)*rij_shift
13374               sigder=fac*sigder
13375               fac=rij*fac-2*expon*rrij*e_augm
13376 ! Calculate the radial part of the gradient
13377               gg(1)=xj*fac
13378               gg(2)=yj*fac
13379               gg(3)=zj*fac
13380 ! Calculate angular part of the gradient.
13381               call sc_grad_scale(sss)
13382             endif
13383           enddo      ! j
13384         enddo        ! iint
13385       enddo          ! i
13386       end subroutine egbv_short
13387 !-----------------------------------------------------------------------------
13388       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13389 !
13390 ! This subroutine calculates the average interaction energy and its gradient
13391 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13392 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13393 ! The potential depends both on the distance of peptide-group centers and on
13394 ! the orientation of the CA-CA virtual bonds.
13395 !
13396 !      implicit real*8 (a-h,o-z)
13397
13398       use comm_locel
13399 #ifdef MPI
13400       include 'mpif.h'
13401 #endif
13402 !      include 'DIMENSIONS'
13403 !      include 'COMMON.CONTROL'
13404 !      include 'COMMON.SETUP'
13405 !      include 'COMMON.IOUNITS'
13406 !      include 'COMMON.GEO'
13407 !      include 'COMMON.VAR'
13408 !      include 'COMMON.LOCAL'
13409 !      include 'COMMON.CHAIN'
13410 !      include 'COMMON.DERIV'
13411 !      include 'COMMON.INTERACT'
13412 !      include 'COMMON.CONTACTS'
13413 !      include 'COMMON.TORSION'
13414 !      include 'COMMON.VECTORS'
13415 !      include 'COMMON.FFIELD'
13416 !      include 'COMMON.TIME1'
13417       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13418       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13419       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13420 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13421       real(kind=8),dimension(4) :: muij
13422 !el      integer :: num_conti,j1,j2
13423 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13424 !el                   dz_normi,xmedi,ymedi,zmedi
13425 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13426 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13427 !el          num_conti,j1,j2
13428 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13429 #ifdef MOMENT
13430       real(kind=8) :: scal_el=1.0d0
13431 #else
13432       real(kind=8) :: scal_el=0.5d0
13433 #endif
13434 ! 12/13/98
13435 ! 13-go grudnia roku pamietnego...
13436       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13437                                              0.0d0,1.0d0,0.0d0,&
13438                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13439 !el local variables
13440       integer :: i,j,k
13441       real(kind=8) :: fac
13442       real(kind=8) :: dxj,dyj,dzj
13443       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13444
13445 !      allocate(num_cont_hb(nres)) !(maxres)
13446 !d      write(iout,*) 'In EELEC'
13447 !d      do i=1,nloctyp
13448 !d        write(iout,*) 'Type',i
13449 !d        write(iout,*) 'B1',B1(:,i)
13450 !d        write(iout,*) 'B2',B2(:,i)
13451 !d        write(iout,*) 'CC',CC(:,:,i)
13452 !d        write(iout,*) 'DD',DD(:,:,i)
13453 !d        write(iout,*) 'EE',EE(:,:,i)
13454 !d      enddo
13455 !d      call check_vecgrad
13456 !d      stop
13457       if (icheckgrad.eq.1) then
13458         do i=1,nres-1
13459           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13460           do k=1,3
13461             dc_norm(k,i)=dc(k,i)*fac
13462           enddo
13463 !          write (iout,*) 'i',i,' fac',fac
13464         enddo
13465       endif
13466       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13467           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13468           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13469 !        call vec_and_deriv
13470 #ifdef TIMING
13471         time01=MPI_Wtime()
13472 #endif
13473 !        print *, "before set matrices"
13474         call set_matrices
13475 !        print *,"after set martices"
13476 #ifdef TIMING
13477         time_mat=time_mat+MPI_Wtime()-time01
13478 #endif
13479       endif
13480 !d      do i=1,nres-1
13481 !d        write (iout,*) 'i=',i
13482 !d        do k=1,3
13483 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
13484 !d        enddo
13485 !d        do k=1,3
13486 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
13487 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
13488 !d        enddo
13489 !d      enddo
13490       t_eelecij=0.0d0
13491       ees=0.0D0
13492       evdw1=0.0D0
13493       eel_loc=0.0d0
13494       eello_turn3=0.0d0
13495       eello_turn4=0.0d0
13496 !el      ind=0
13497       do i=1,nres
13498         num_cont_hb(i)=0
13499       enddo
13500 !d      print '(a)','Enter EELEC'
13501 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
13502 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13503 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13504       do i=1,nres
13505         gel_loc_loc(i)=0.0d0
13506         gcorr_loc(i)=0.0d0
13507       enddo
13508 !
13509 !
13510 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
13511 !
13512 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
13513 !
13514       do i=iturn3_start,iturn3_end
13515         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
13516         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
13517         dxi=dc(1,i)
13518         dyi=dc(2,i)
13519         dzi=dc(3,i)
13520         dx_normi=dc_norm(1,i)
13521         dy_normi=dc_norm(2,i)
13522         dz_normi=dc_norm(3,i)
13523         xmedi=c(1,i)+0.5d0*dxi
13524         ymedi=c(2,i)+0.5d0*dyi
13525         zmedi=c(3,i)+0.5d0*dzi
13526           xmedi=dmod(xmedi,boxxsize)
13527           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13528           ymedi=dmod(ymedi,boxysize)
13529           if (ymedi.lt.0) ymedi=ymedi+boxysize
13530           zmedi=dmod(zmedi,boxzsize)
13531           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13532         num_conti=0
13533         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
13534         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
13535         num_cont_hb(i)=num_conti
13536       enddo
13537       do i=iturn4_start,iturn4_end
13538         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
13539           .or. itype(i+3).eq.ntyp1 &
13540           .or. itype(i+4).eq.ntyp1) cycle
13541         dxi=dc(1,i)
13542         dyi=dc(2,i)
13543         dzi=dc(3,i)
13544         dx_normi=dc_norm(1,i)
13545         dy_normi=dc_norm(2,i)
13546         dz_normi=dc_norm(3,i)
13547         xmedi=c(1,i)+0.5d0*dxi
13548         ymedi=c(2,i)+0.5d0*dyi
13549         zmedi=c(3,i)+0.5d0*dzi
13550           xmedi=dmod(xmedi,boxxsize)
13551           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13552           ymedi=dmod(ymedi,boxysize)
13553           if (ymedi.lt.0) ymedi=ymedi+boxysize
13554           zmedi=dmod(zmedi,boxzsize)
13555           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13556         num_conti=num_cont_hb(i)
13557         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
13558         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
13559           call eturn4(i,eello_turn4)
13560         num_cont_hb(i)=num_conti
13561       enddo   ! i
13562 !
13563 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
13564 !
13565       do i=iatel_s,iatel_e
13566         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
13567         dxi=dc(1,i)
13568         dyi=dc(2,i)
13569         dzi=dc(3,i)
13570         dx_normi=dc_norm(1,i)
13571         dy_normi=dc_norm(2,i)
13572         dz_normi=dc_norm(3,i)
13573         xmedi=c(1,i)+0.5d0*dxi
13574         ymedi=c(2,i)+0.5d0*dyi
13575         zmedi=c(3,i)+0.5d0*dzi
13576           xmedi=dmod(xmedi,boxxsize)
13577           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13578           ymedi=dmod(ymedi,boxysize)
13579           if (ymedi.lt.0) ymedi=ymedi+boxysize
13580           zmedi=dmod(zmedi,boxzsize)
13581           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13582 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
13583         num_conti=num_cont_hb(i)
13584         do j=ielstart(i),ielend(i)
13585           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
13586           call eelecij_scale(i,j,ees,evdw1,eel_loc)
13587         enddo ! j
13588         num_cont_hb(i)=num_conti
13589       enddo   ! i
13590 !      write (iout,*) "Number of loop steps in EELEC:",ind
13591 !d      do i=1,nres
13592 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
13593 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
13594 !d      enddo
13595 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
13596 !cc      eel_loc=eel_loc+eello_turn3
13597 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
13598       return
13599       end subroutine eelec_scale
13600 !-----------------------------------------------------------------------------
13601       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
13602 !      implicit real*8 (a-h,o-z)
13603
13604       use comm_locel
13605 !      include 'DIMENSIONS'
13606 #ifdef MPI
13607       include "mpif.h"
13608 #endif
13609 !      include 'COMMON.CONTROL'
13610 !      include 'COMMON.IOUNITS'
13611 !      include 'COMMON.GEO'
13612 !      include 'COMMON.VAR'
13613 !      include 'COMMON.LOCAL'
13614 !      include 'COMMON.CHAIN'
13615 !      include 'COMMON.DERIV'
13616 !      include 'COMMON.INTERACT'
13617 !      include 'COMMON.CONTACTS'
13618 !      include 'COMMON.TORSION'
13619 !      include 'COMMON.VECTORS'
13620 !      include 'COMMON.FFIELD'
13621 !      include 'COMMON.TIME1'
13622       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
13623       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
13624       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13625 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13626       real(kind=8),dimension(4) :: muij
13627       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13628                     dist_temp, dist_init,sss_grad
13629       integer xshift,yshift,zshift
13630
13631 !el      integer :: num_conti,j1,j2
13632 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13633 !el                   dz_normi,xmedi,ymedi,zmedi
13634 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13635 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13636 !el          num_conti,j1,j2
13637 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13638 #ifdef MOMENT
13639       real(kind=8) :: scal_el=1.0d0
13640 #else
13641       real(kind=8) :: scal_el=0.5d0
13642 #endif
13643 ! 12/13/98
13644 ! 13-go grudnia roku pamietnego...
13645       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13646                                              0.0d0,1.0d0,0.0d0,&
13647                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13648 !el local variables
13649       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
13650       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
13651       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
13652       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
13653       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
13654       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
13655       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
13656                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
13657                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
13658                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
13659                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
13660                   ecosam,ecosbm,ecosgm,ghalf,time00
13661 !      integer :: maxconts
13662 !      maxconts = nres/4
13663 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13664 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13665 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13666 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13667 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13668 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13669 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13670 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13671 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
13672 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
13673 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
13674 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
13675 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
13676
13677 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
13678 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
13679
13680 #ifdef MPI
13681           time00=MPI_Wtime()
13682 #endif
13683 !d      write (iout,*) "eelecij",i,j
13684 !el          ind=ind+1
13685           iteli=itel(i)
13686           itelj=itel(j)
13687           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
13688           aaa=app(iteli,itelj)
13689           bbb=bpp(iteli,itelj)
13690           ael6i=ael6(iteli,itelj)
13691           ael3i=ael3(iteli,itelj)
13692           dxj=dc(1,j)
13693           dyj=dc(2,j)
13694           dzj=dc(3,j)
13695           dx_normj=dc_norm(1,j)
13696           dy_normj=dc_norm(2,j)
13697           dz_normj=dc_norm(3,j)
13698 !          xj=c(1,j)+0.5D0*dxj-xmedi
13699 !          yj=c(2,j)+0.5D0*dyj-ymedi
13700 !          zj=c(3,j)+0.5D0*dzj-zmedi
13701           xj=c(1,j)+0.5D0*dxj
13702           yj=c(2,j)+0.5D0*dyj
13703           zj=c(3,j)+0.5D0*dzj
13704           xj=mod(xj,boxxsize)
13705           if (xj.lt.0) xj=xj+boxxsize
13706           yj=mod(yj,boxysize)
13707           if (yj.lt.0) yj=yj+boxysize
13708           zj=mod(zj,boxzsize)
13709           if (zj.lt.0) zj=zj+boxzsize
13710       isubchap=0
13711       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13712       xj_safe=xj
13713       yj_safe=yj
13714       zj_safe=zj
13715       do xshift=-1,1
13716       do yshift=-1,1
13717       do zshift=-1,1
13718           xj=xj_safe+xshift*boxxsize
13719           yj=yj_safe+yshift*boxysize
13720           zj=zj_safe+zshift*boxzsize
13721           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13722           if(dist_temp.lt.dist_init) then
13723             dist_init=dist_temp
13724             xj_temp=xj
13725             yj_temp=yj
13726             zj_temp=zj
13727             isubchap=1
13728           endif
13729        enddo
13730        enddo
13731        enddo
13732        if (isubchap.eq.1) then
13733 !C          print *,i,j
13734           xj=xj_temp-xmedi
13735           yj=yj_temp-ymedi
13736           zj=zj_temp-zmedi
13737        else
13738           xj=xj_safe-xmedi
13739           yj=yj_safe-ymedi
13740           zj=zj_safe-zmedi
13741        endif
13742
13743           rij=xj*xj+yj*yj+zj*zj
13744           rrmij=1.0D0/rij
13745           rij=dsqrt(rij)
13746           rmij=1.0D0/rij
13747 ! For extracting the short-range part of Evdwpp
13748           sss=sscale(rij/rpp(iteli,itelj))
13749             sss_ele_cut=sscale_ele(rij)
13750             sss_ele_grad=sscagrad_ele(rij)
13751             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
13752 !             sss_ele_cut=1.0d0
13753 !             sss_ele_grad=0.0d0
13754             if (sss_ele_cut.le.0.0) go to 128
13755
13756           r3ij=rrmij*rmij
13757           r6ij=r3ij*r3ij
13758           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
13759           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
13760           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
13761           fac=cosa-3.0D0*cosb*cosg
13762           ev1=aaa*r6ij*r6ij
13763 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
13764           if (j.eq.i+2) ev1=scal_el*ev1
13765           ev2=bbb*r6ij
13766           fac3=ael6i*r6ij
13767           fac4=ael3i*r3ij
13768           evdwij=ev1+ev2
13769           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
13770           el2=fac4*fac
13771           eesij=el1+el2
13772 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
13773           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
13774           ees=ees+eesij*sss_ele_cut
13775           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
13776 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
13777 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
13778 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
13779 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
13780
13781           if (energy_dec) then
13782               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
13783               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
13784           endif
13785
13786 !
13787 ! Calculate contributions to the Cartesian gradient.
13788 !
13789 #ifdef SPLITELE
13790           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
13791           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
13792           fac1=fac
13793           erij(1)=xj*rmij
13794           erij(2)=yj*rmij
13795           erij(3)=zj*rmij
13796 !
13797 ! Radial derivatives. First process both termini of the fragment (i,j)
13798 !
13799           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
13800           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
13801           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
13802 !          do k=1,3
13803 !            ghalf=0.5D0*ggg(k)
13804 !            gelc(k,i)=gelc(k,i)+ghalf
13805 !            gelc(k,j)=gelc(k,j)+ghalf
13806 !          enddo
13807 ! 9/28/08 AL Gradient compotents will be summed only at the end
13808           do k=1,3
13809             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
13810             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
13811           enddo
13812 !
13813 ! Loop over residues i+1 thru j-1.
13814 !
13815 !grad          do k=i+1,j-1
13816 !grad            do l=1,3
13817 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
13818 !grad            enddo
13819 !grad          enddo
13820           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
13821           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
13822           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
13823           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
13824           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
13825           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
13826 !          do k=1,3
13827 !            ghalf=0.5D0*ggg(k)
13828 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
13829 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
13830 !          enddo
13831 ! 9/28/08 AL Gradient compotents will be summed only at the end
13832           do k=1,3
13833             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
13834             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
13835           enddo
13836 !
13837 ! Loop over residues i+1 thru j-1.
13838 !
13839 !grad          do k=i+1,j-1
13840 !grad            do l=1,3
13841 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
13842 !grad            enddo
13843 !grad          enddo
13844 #else
13845           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
13846           facel=(el1+eesij)*sss_ele_cut
13847           fac1=fac
13848           fac=-3*rrmij*(facvdw+facvdw+facel)
13849           erij(1)=xj*rmij
13850           erij(2)=yj*rmij
13851           erij(3)=zj*rmij
13852 !
13853 ! Radial derivatives. First process both termini of the fragment (i,j)
13854 !
13855           ggg(1)=fac*xj
13856           ggg(2)=fac*yj
13857           ggg(3)=fac*zj
13858 !          do k=1,3
13859 !            ghalf=0.5D0*ggg(k)
13860 !            gelc(k,i)=gelc(k,i)+ghalf
13861 !            gelc(k,j)=gelc(k,j)+ghalf
13862 !          enddo
13863 ! 9/28/08 AL Gradient compotents will be summed only at the end
13864           do k=1,3
13865             gelc_long(k,j)=gelc(k,j)+ggg(k)
13866             gelc_long(k,i)=gelc(k,i)-ggg(k)
13867           enddo
13868 !
13869 ! Loop over residues i+1 thru j-1.
13870 !
13871 !grad          do k=i+1,j-1
13872 !grad            do l=1,3
13873 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
13874 !grad            enddo
13875 !grad          enddo
13876 ! 9/28/08 AL Gradient compotents will be summed only at the end
13877           ggg(1)=facvdw*xj
13878           ggg(2)=facvdw*yj
13879           ggg(3)=facvdw*zj
13880           do k=1,3
13881             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
13882             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
13883           enddo
13884 #endif
13885 !
13886 ! Angular part
13887 !
13888           ecosa=2.0D0*fac3*fac1+fac4
13889           fac4=-3.0D0*fac4
13890           fac3=-6.0D0*fac3
13891           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
13892           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
13893           do k=1,3
13894             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
13895             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
13896           enddo
13897 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
13898 !d   &          (dcosg(k),k=1,3)
13899           do k=1,3
13900             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
13901           enddo
13902 !          do k=1,3
13903 !            ghalf=0.5D0*ggg(k)
13904 !            gelc(k,i)=gelc(k,i)+ghalf
13905 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
13906 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13907 !            gelc(k,j)=gelc(k,j)+ghalf
13908 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
13909 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13910 !          enddo
13911 !grad          do k=i+1,j-1
13912 !grad            do l=1,3
13913 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
13914 !grad            enddo
13915 !grad          enddo
13916           do k=1,3
13917             gelc(k,i)=gelc(k,i) &
13918                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13919                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
13920                      *sss_ele_cut
13921             gelc(k,j)=gelc(k,j) &
13922                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13923                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
13924                      *sss_ele_cut
13925             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
13926             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
13927           enddo
13928           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13929               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
13930               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
13931 !
13932 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
13933 !   energy of a peptide unit is assumed in the form of a second-order
13934 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
13935 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
13936 !   are computed for EVERY pair of non-contiguous peptide groups.
13937 !
13938           if (j.lt.nres-1) then
13939             j1=j+1
13940             j2=j-1
13941           else
13942             j1=j-1
13943             j2=j-2
13944           endif
13945           kkk=0
13946           do k=1,2
13947             do l=1,2
13948               kkk=kkk+1
13949               muij(kkk)=mu(k,i)*mu(l,j)
13950             enddo
13951           enddo
13952 !d         write (iout,*) 'EELEC: i',i,' j',j
13953 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
13954 !d          write(iout,*) 'muij',muij
13955           ury=scalar(uy(1,i),erij)
13956           urz=scalar(uz(1,i),erij)
13957           vry=scalar(uy(1,j),erij)
13958           vrz=scalar(uz(1,j),erij)
13959           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
13960           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
13961           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
13962           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
13963           fac=dsqrt(-ael6i)*r3ij
13964           a22=a22*fac
13965           a23=a23*fac
13966           a32=a32*fac
13967           a33=a33*fac
13968 !d          write (iout,'(4i5,4f10.5)')
13969 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
13970 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
13971 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
13972 !d     &      uy(:,j),uz(:,j)
13973 !d          write (iout,'(4f10.5)')
13974 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
13975 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
13976 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
13977 !d           write (iout,'(9f10.5/)')
13978 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
13979 ! Derivatives of the elements of A in virtual-bond vectors
13980           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
13981           do k=1,3
13982             uryg(k,1)=scalar(erder(1,k),uy(1,i))
13983             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
13984             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
13985             urzg(k,1)=scalar(erder(1,k),uz(1,i))
13986             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
13987             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
13988             vryg(k,1)=scalar(erder(1,k),uy(1,j))
13989             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
13990             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
13991             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
13992             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
13993             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
13994           enddo
13995 ! Compute radial contributions to the gradient
13996           facr=-3.0d0*rrmij
13997           a22der=a22*facr
13998           a23der=a23*facr
13999           a32der=a32*facr
14000           a33der=a33*facr
14001           agg(1,1)=a22der*xj
14002           agg(2,1)=a22der*yj
14003           agg(3,1)=a22der*zj
14004           agg(1,2)=a23der*xj
14005           agg(2,2)=a23der*yj
14006           agg(3,2)=a23der*zj
14007           agg(1,3)=a32der*xj
14008           agg(2,3)=a32der*yj
14009           agg(3,3)=a32der*zj
14010           agg(1,4)=a33der*xj
14011           agg(2,4)=a33der*yj
14012           agg(3,4)=a33der*zj
14013 ! Add the contributions coming from er
14014           fac3=-3.0d0*fac
14015           do k=1,3
14016             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14017             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14018             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14019             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14020           enddo
14021           do k=1,3
14022 ! Derivatives in DC(i)
14023 !grad            ghalf1=0.5d0*agg(k,1)
14024 !grad            ghalf2=0.5d0*agg(k,2)
14025 !grad            ghalf3=0.5d0*agg(k,3)
14026 !grad            ghalf4=0.5d0*agg(k,4)
14027             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14028             -3.0d0*uryg(k,2)*vry)!+ghalf1
14029             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14030             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14031             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14032             -3.0d0*urzg(k,2)*vry)!+ghalf3
14033             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14034             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14035 ! Derivatives in DC(i+1)
14036             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14037             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14038             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14039             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14040             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14041             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14042             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14043             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14044 ! Derivatives in DC(j)
14045             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14046             -3.0d0*vryg(k,2)*ury)!+ghalf1
14047             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14048             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14049             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14050             -3.0d0*vryg(k,2)*urz)!+ghalf3
14051             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14052             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14053 ! Derivatives in DC(j+1) or DC(nres-1)
14054             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14055             -3.0d0*vryg(k,3)*ury)
14056             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14057             -3.0d0*vrzg(k,3)*ury)
14058             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14059             -3.0d0*vryg(k,3)*urz)
14060             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14061             -3.0d0*vrzg(k,3)*urz)
14062 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14063 !grad              do l=1,4
14064 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14065 !grad              enddo
14066 !grad            endif
14067           enddo
14068           acipa(1,1)=a22
14069           acipa(1,2)=a23
14070           acipa(2,1)=a32
14071           acipa(2,2)=a33
14072           a22=-a22
14073           a23=-a23
14074           do l=1,2
14075             do k=1,3
14076               agg(k,l)=-agg(k,l)
14077               aggi(k,l)=-aggi(k,l)
14078               aggi1(k,l)=-aggi1(k,l)
14079               aggj(k,l)=-aggj(k,l)
14080               aggj1(k,l)=-aggj1(k,l)
14081             enddo
14082           enddo
14083           if (j.lt.nres-1) then
14084             a22=-a22
14085             a32=-a32
14086             do l=1,3,2
14087               do k=1,3
14088                 agg(k,l)=-agg(k,l)
14089                 aggi(k,l)=-aggi(k,l)
14090                 aggi1(k,l)=-aggi1(k,l)
14091                 aggj(k,l)=-aggj(k,l)
14092                 aggj1(k,l)=-aggj1(k,l)
14093               enddo
14094             enddo
14095           else
14096             a22=-a22
14097             a23=-a23
14098             a32=-a32
14099             a33=-a33
14100             do l=1,4
14101               do k=1,3
14102                 agg(k,l)=-agg(k,l)
14103                 aggi(k,l)=-aggi(k,l)
14104                 aggi1(k,l)=-aggi1(k,l)
14105                 aggj(k,l)=-aggj(k,l)
14106                 aggj1(k,l)=-aggj1(k,l)
14107               enddo
14108             enddo
14109           endif
14110           ENDIF ! WCORR
14111           IF (wel_loc.gt.0.0d0) THEN
14112 ! Contribution to the local-electrostatic energy coming from the i-j pair
14113           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14114            +a33*muij(4)
14115 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14116
14117           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14118                   'eelloc',i,j,eel_loc_ij
14119 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14120
14121           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14122 ! Partial derivatives in virtual-bond dihedral angles gamma
14123           if (i.gt.1) &
14124           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14125                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14126                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14127                  *sss_ele_cut
14128           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14129                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14130                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14131                  *sss_ele_cut
14132            xtemp(1)=xj
14133            xtemp(2)=yj
14134            xtemp(3)=zj
14135
14136 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14137           do l=1,3
14138             ggg(l)=(agg(l,1)*muij(1)+ &
14139                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14140             *sss_ele_cut &
14141              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14142
14143             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14144             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14145 !grad            ghalf=0.5d0*ggg(l)
14146 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14147 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14148           enddo
14149 !grad          do k=i+1,j2
14150 !grad            do l=1,3
14151 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14152 !grad            enddo
14153 !grad          enddo
14154 ! Remaining derivatives of eello
14155           do l=1,3
14156             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14157                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14158             *sss_ele_cut
14159
14160             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14161                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14162             *sss_ele_cut
14163
14164             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14165                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14166             *sss_ele_cut
14167
14168             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14169                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14170             *sss_ele_cut
14171
14172           enddo
14173           ENDIF
14174 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14175 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14176           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14177              .and. num_conti.le.maxconts) then
14178 !            write (iout,*) i,j," entered corr"
14179 !
14180 ! Calculate the contact function. The ith column of the array JCONT will
14181 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14182 ! greater than I). The arrays FACONT and GACONT will contain the values of
14183 ! the contact function and its derivative.
14184 !           r0ij=1.02D0*rpp(iteli,itelj)
14185 !           r0ij=1.11D0*rpp(iteli,itelj)
14186             r0ij=2.20D0*rpp(iteli,itelj)
14187 !           r0ij=1.55D0*rpp(iteli,itelj)
14188             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14189 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14190             if (fcont.gt.0.0D0) then
14191               num_conti=num_conti+1
14192               if (num_conti.gt.maxconts) then
14193 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14194                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14195                                ' will skip next contacts for this conf.',num_conti
14196               else
14197                 jcont_hb(num_conti,i)=j
14198 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14199 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14200                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14201                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14202 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14203 !  terms.
14204                 d_cont(num_conti,i)=rij
14205 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14206 !     --- Electrostatic-interaction matrix ---
14207                 a_chuj(1,1,num_conti,i)=a22
14208                 a_chuj(1,2,num_conti,i)=a23
14209                 a_chuj(2,1,num_conti,i)=a32
14210                 a_chuj(2,2,num_conti,i)=a33
14211 !     --- Gradient of rij
14212                 do kkk=1,3
14213                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14214                 enddo
14215                 kkll=0
14216                 do k=1,2
14217                   do l=1,2
14218                     kkll=kkll+1
14219                     do m=1,3
14220                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14221                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14222                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14223                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14224                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14225                     enddo
14226                   enddo
14227                 enddo
14228                 ENDIF
14229                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14230 ! Calculate contact energies
14231                 cosa4=4.0D0*cosa
14232                 wij=cosa-3.0D0*cosb*cosg
14233                 cosbg1=cosb+cosg
14234                 cosbg2=cosb-cosg
14235 !               fac3=dsqrt(-ael6i)/r0ij**3
14236                 fac3=dsqrt(-ael6i)*r3ij
14237 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14238                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14239                 if (ees0tmp.gt.0) then
14240                   ees0pij=dsqrt(ees0tmp)
14241                 else
14242                   ees0pij=0
14243                 endif
14244 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14245                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14246                 if (ees0tmp.gt.0) then
14247                   ees0mij=dsqrt(ees0tmp)
14248                 else
14249                   ees0mij=0
14250                 endif
14251 !               ees0mij=0.0D0
14252                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14253                      *sss_ele_cut
14254
14255                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14256                      *sss_ele_cut
14257
14258 ! Diagnostics. Comment out or remove after debugging!
14259 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14260 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14261 !               ees0m(num_conti,i)=0.0D0
14262 ! End diagnostics.
14263 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14264 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14265 ! Angular derivatives of the contact function
14266                 ees0pij1=fac3/ees0pij
14267                 ees0mij1=fac3/ees0mij
14268                 fac3p=-3.0D0*fac3*rrmij
14269                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14270                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14271 !               ees0mij1=0.0D0
14272                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14273                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14274                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14275                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14276                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14277                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14278                 ecosap=ecosa1+ecosa2
14279                 ecosbp=ecosb1+ecosb2
14280                 ecosgp=ecosg1+ecosg2
14281                 ecosam=ecosa1-ecosa2
14282                 ecosbm=ecosb1-ecosb2
14283                 ecosgm=ecosg1-ecosg2
14284 ! Diagnostics
14285 !               ecosap=ecosa1
14286 !               ecosbp=ecosb1
14287 !               ecosgp=ecosg1
14288 !               ecosam=0.0D0
14289 !               ecosbm=0.0D0
14290 !               ecosgm=0.0D0
14291 ! End diagnostics
14292                 facont_hb(num_conti,i)=fcont
14293                 fprimcont=fprimcont/rij
14294 !d              facont_hb(num_conti,i)=1.0D0
14295 ! Following line is for diagnostics.
14296 !d              fprimcont=0.0D0
14297                 do k=1,3
14298                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14299                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14300                 enddo
14301                 do k=1,3
14302                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14303                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14304                 enddo
14305 !                gggp(1)=gggp(1)+ees0pijp*xj
14306 !                gggp(2)=gggp(2)+ees0pijp*yj
14307 !                gggp(3)=gggp(3)+ees0pijp*zj
14308 !                gggm(1)=gggm(1)+ees0mijp*xj
14309 !                gggm(2)=gggm(2)+ees0mijp*yj
14310 !                gggm(3)=gggm(3)+ees0mijp*zj
14311                 gggp(1)=gggp(1)+ees0pijp*xj &
14312                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14313                 gggp(2)=gggp(2)+ees0pijp*yj &
14314                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14315                 gggp(3)=gggp(3)+ees0pijp*zj &
14316                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14317
14318                 gggm(1)=gggm(1)+ees0mijp*xj &
14319                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14320
14321                 gggm(2)=gggm(2)+ees0mijp*yj &
14322                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14323
14324                 gggm(3)=gggm(3)+ees0mijp*zj &
14325                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14326
14327 ! Derivatives due to the contact function
14328                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14329                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14330                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14331                 do k=1,3
14332 !
14333 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14334 !          following the change of gradient-summation algorithm.
14335 !
14336 !grad                  ghalfp=0.5D0*gggp(k)
14337 !grad                  ghalfm=0.5D0*gggm(k)
14338 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14339 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14340 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14341 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14342 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14343 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14344 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14345 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14346 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14347 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14348 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14349 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14350 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14351 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14352                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14353                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14354                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14355                      *sss_ele_cut
14356
14357                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14358                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14359                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14360                      *sss_ele_cut
14361
14362                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14363                      *sss_ele_cut
14364
14365                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14366                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14367                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14368                      *sss_ele_cut
14369
14370                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14371                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14372                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14373                      *sss_ele_cut
14374
14375                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14376                      *sss_ele_cut
14377
14378                 enddo
14379               ENDIF ! wcorr
14380               endif  ! num_conti.le.maxconts
14381             endif  ! fcont.gt.0
14382           endif    ! j.gt.i+1
14383           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14384             do k=1,4
14385               do l=1,3
14386                 ghalf=0.5d0*agg(l,k)
14387                 aggi(l,k)=aggi(l,k)+ghalf
14388                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14389                 aggj(l,k)=aggj(l,k)+ghalf
14390               enddo
14391             enddo
14392             if (j.eq.nres-1 .and. i.lt.j-2) then
14393               do k=1,4
14394                 do l=1,3
14395                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14396                 enddo
14397               enddo
14398             endif
14399           endif
14400  128      continue
14401 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14402       return
14403       end subroutine eelecij_scale
14404 !-----------------------------------------------------------------------------
14405       subroutine evdwpp_short(evdw1)
14406 !
14407 ! Compute Evdwpp
14408 !
14409 !      implicit real*8 (a-h,o-z)
14410 !      include 'DIMENSIONS'
14411 !      include 'COMMON.CONTROL'
14412 !      include 'COMMON.IOUNITS'
14413 !      include 'COMMON.GEO'
14414 !      include 'COMMON.VAR'
14415 !      include 'COMMON.LOCAL'
14416 !      include 'COMMON.CHAIN'
14417 !      include 'COMMON.DERIV'
14418 !      include 'COMMON.INTERACT'
14419 !      include 'COMMON.CONTACTS'
14420 !      include 'COMMON.TORSION'
14421 !      include 'COMMON.VECTORS'
14422 !      include 'COMMON.FFIELD'
14423       real(kind=8),dimension(3) :: ggg
14424 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14425 #ifdef MOMENT
14426       real(kind=8) :: scal_el=1.0d0
14427 #else
14428       real(kind=8) :: scal_el=0.5d0
14429 #endif
14430 !el local variables
14431       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14432       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14433       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14434                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14435                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14436       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14437                     dist_temp, dist_init,sss_grad
14438       integer xshift,yshift,zshift
14439
14440
14441       evdw1=0.0D0
14442 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14443 !     & " iatel_e_vdw",iatel_e_vdw
14444       call flush(iout)
14445       do i=iatel_s_vdw,iatel_e_vdw
14446         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
14447         dxi=dc(1,i)
14448         dyi=dc(2,i)
14449         dzi=dc(3,i)
14450         dx_normi=dc_norm(1,i)
14451         dy_normi=dc_norm(2,i)
14452         dz_normi=dc_norm(3,i)
14453         xmedi=c(1,i)+0.5d0*dxi
14454         ymedi=c(2,i)+0.5d0*dyi
14455         zmedi=c(3,i)+0.5d0*dzi
14456           xmedi=dmod(xmedi,boxxsize)
14457           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14458           ymedi=dmod(ymedi,boxysize)
14459           if (ymedi.lt.0) ymedi=ymedi+boxysize
14460           zmedi=dmod(zmedi,boxzsize)
14461           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14462         num_conti=0
14463 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14464 !     &   ' ielend',ielend_vdw(i)
14465         call flush(iout)
14466         do j=ielstart_vdw(i),ielend_vdw(i)
14467           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
14468 !el          ind=ind+1
14469           iteli=itel(i)
14470           itelj=itel(j)
14471           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14472           aaa=app(iteli,itelj)
14473           bbb=bpp(iteli,itelj)
14474           dxj=dc(1,j)
14475           dyj=dc(2,j)
14476           dzj=dc(3,j)
14477           dx_normj=dc_norm(1,j)
14478           dy_normj=dc_norm(2,j)
14479           dz_normj=dc_norm(3,j)
14480 !          xj=c(1,j)+0.5D0*dxj-xmedi
14481 !          yj=c(2,j)+0.5D0*dyj-ymedi
14482 !          zj=c(3,j)+0.5D0*dzj-zmedi
14483           xj=c(1,j)+0.5D0*dxj
14484           yj=c(2,j)+0.5D0*dyj
14485           zj=c(3,j)+0.5D0*dzj
14486           xj=mod(xj,boxxsize)
14487           if (xj.lt.0) xj=xj+boxxsize
14488           yj=mod(yj,boxysize)
14489           if (yj.lt.0) yj=yj+boxysize
14490           zj=mod(zj,boxzsize)
14491           if (zj.lt.0) zj=zj+boxzsize
14492       isubchap=0
14493       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14494       xj_safe=xj
14495       yj_safe=yj
14496       zj_safe=zj
14497       do xshift=-1,1
14498       do yshift=-1,1
14499       do zshift=-1,1
14500           xj=xj_safe+xshift*boxxsize
14501           yj=yj_safe+yshift*boxysize
14502           zj=zj_safe+zshift*boxzsize
14503           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14504           if(dist_temp.lt.dist_init) then
14505             dist_init=dist_temp
14506             xj_temp=xj
14507             yj_temp=yj
14508             zj_temp=zj
14509             isubchap=1
14510           endif
14511        enddo
14512        enddo
14513        enddo
14514        if (isubchap.eq.1) then
14515 !C          print *,i,j
14516           xj=xj_temp-xmedi
14517           yj=yj_temp-ymedi
14518           zj=zj_temp-zmedi
14519        else
14520           xj=xj_safe-xmedi
14521           yj=yj_safe-ymedi
14522           zj=zj_safe-zmedi
14523        endif
14524
14525           rij=xj*xj+yj*yj+zj*zj
14526           rrmij=1.0D0/rij
14527           rij=dsqrt(rij)
14528           sss=sscale(rij/rpp(iteli,itelj))
14529             sss_ele_cut=sscale_ele(rij)
14530             sss_ele_grad=sscagrad_ele(rij)
14531             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14532             if (sss_ele_cut.le.0.0) cycle
14533           if (sss.gt.0.0d0) then
14534             rmij=1.0D0/rij
14535             r3ij=rrmij*rmij
14536             r6ij=r3ij*r3ij
14537             ev1=aaa*r6ij*r6ij
14538 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14539             if (j.eq.i+2) ev1=scal_el*ev1
14540             ev2=bbb*r6ij
14541             evdwij=ev1+ev2
14542             if (energy_dec) then
14543               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14544             endif
14545             evdw1=evdw1+evdwij*sss*sss_ele_cut
14546 !
14547 ! Calculate contributions to the Cartesian gradient.
14548 !
14549             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
14550 !            ggg(1)=facvdw*xj
14551 !            ggg(2)=facvdw*yj
14552 !            ggg(3)=facvdw*zj
14553           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
14554           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14555           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
14556           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14557           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
14558           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14559
14560             do k=1,3
14561               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14562               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14563             enddo
14564           endif
14565         enddo ! j
14566       enddo   ! i
14567       return
14568       end subroutine evdwpp_short
14569 !-----------------------------------------------------------------------------
14570       subroutine escp_long(evdw2,evdw2_14)
14571 !
14572 ! This subroutine calculates the excluded-volume interaction energy between
14573 ! peptide-group centers and side chains and its gradient in virtual-bond and
14574 ! side-chain vectors.
14575 !
14576 !      implicit real*8 (a-h,o-z)
14577 !      include 'DIMENSIONS'
14578 !      include 'COMMON.GEO'
14579 !      include 'COMMON.VAR'
14580 !      include 'COMMON.LOCAL'
14581 !      include 'COMMON.CHAIN'
14582 !      include 'COMMON.DERIV'
14583 !      include 'COMMON.INTERACT'
14584 !      include 'COMMON.FFIELD'
14585 !      include 'COMMON.IOUNITS'
14586 !      include 'COMMON.CONTROL'
14587       real(kind=8),dimension(3) :: ggg
14588 !el local variables
14589       integer :: i,iint,j,k,iteli,itypj,subchap
14590       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
14591       real(kind=8) :: evdw2,evdw2_14,evdwij
14592       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14593                     dist_temp, dist_init
14594
14595       evdw2=0.0D0
14596       evdw2_14=0.0d0
14597 !d    print '(a)','Enter ESCP'
14598 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
14599       do i=iatscp_s,iatscp_e
14600         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
14601         iteli=itel(i)
14602         xi=0.5D0*(c(1,i)+c(1,i+1))
14603         yi=0.5D0*(c(2,i)+c(2,i+1))
14604         zi=0.5D0*(c(3,i)+c(3,i+1))
14605           xi=mod(xi,boxxsize)
14606           if (xi.lt.0) xi=xi+boxxsize
14607           yi=mod(yi,boxysize)
14608           if (yi.lt.0) yi=yi+boxysize
14609           zi=mod(zi,boxzsize)
14610           if (zi.lt.0) zi=zi+boxzsize
14611
14612         do iint=1,nscp_gr(i)
14613
14614         do j=iscpstart(i,iint),iscpend(i,iint)
14615           itypj=itype(j)
14616           if (itypj.eq.ntyp1) cycle
14617 ! Uncomment following three lines for SC-p interactions
14618 !         xj=c(1,nres+j)-xi
14619 !         yj=c(2,nres+j)-yi
14620 !         zj=c(3,nres+j)-zi
14621 ! Uncomment following three lines for Ca-p interactions
14622           xj=c(1,j)
14623           yj=c(2,j)
14624           zj=c(3,j)
14625           xj=mod(xj,boxxsize)
14626           if (xj.lt.0) xj=xj+boxxsize
14627           yj=mod(yj,boxysize)
14628           if (yj.lt.0) yj=yj+boxysize
14629           zj=mod(zj,boxzsize)
14630           if (zj.lt.0) zj=zj+boxzsize
14631       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14632       xj_safe=xj
14633       yj_safe=yj
14634       zj_safe=zj
14635       subchap=0
14636       do xshift=-1,1
14637       do yshift=-1,1
14638       do zshift=-1,1
14639           xj=xj_safe+xshift*boxxsize
14640           yj=yj_safe+yshift*boxysize
14641           zj=zj_safe+zshift*boxzsize
14642           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14643           if(dist_temp.lt.dist_init) then
14644             dist_init=dist_temp
14645             xj_temp=xj
14646             yj_temp=yj
14647             zj_temp=zj
14648             subchap=1
14649           endif
14650        enddo
14651        enddo
14652        enddo
14653        if (subchap.eq.1) then
14654           xj=xj_temp-xi
14655           yj=yj_temp-yi
14656           zj=zj_temp-zi
14657        else
14658           xj=xj_safe-xi
14659           yj=yj_safe-yi
14660           zj=zj_safe-zi
14661        endif
14662           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14663
14664           rij=dsqrt(1.0d0/rrij)
14665             sss_ele_cut=sscale_ele(rij)
14666             sss_ele_grad=sscagrad_ele(rij)
14667 !            print *,sss_ele_cut,sss_ele_grad,&
14668 !            (rij),r_cut_ele,rlamb_ele
14669             if (sss_ele_cut.le.0.0) cycle
14670           sss=sscale((rij/rscp(itypj,iteli)))
14671           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
14672           if (sss.lt.1.0d0) then
14673
14674             fac=rrij**expon2
14675             e1=fac*fac*aad(itypj,iteli)
14676             e2=fac*bad(itypj,iteli)
14677             if (iabs(j-i) .le. 2) then
14678               e1=scal14*e1
14679               e2=scal14*e2
14680               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
14681             endif
14682             evdwij=e1+e2
14683             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
14684             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
14685                 'evdw2',i,j,sss,evdwij
14686 !
14687 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
14688 !
14689             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
14690             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
14691             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
14692             ggg(1)=xj*fac
14693             ggg(2)=yj*fac
14694             ggg(3)=zj*fac
14695 ! Uncomment following three lines for SC-p interactions
14696 !           do k=1,3
14697 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14698 !           enddo
14699 ! Uncomment following line for SC-p interactions
14700 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14701             do k=1,3
14702               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
14703               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
14704             enddo
14705           endif
14706         enddo
14707
14708         enddo ! iint
14709       enddo ! i
14710       do i=1,nct
14711         do j=1,3
14712           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
14713           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
14714           gradx_scp(j,i)=expon*gradx_scp(j,i)
14715         enddo
14716       enddo
14717 !******************************************************************************
14718 !
14719 !                              N O T E !!!
14720 !
14721 ! To save time the factor EXPON has been extracted from ALL components
14722 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14723 ! use!
14724 !
14725 !******************************************************************************
14726       return
14727       end subroutine escp_long
14728 !-----------------------------------------------------------------------------
14729       subroutine escp_short(evdw2,evdw2_14)
14730 !
14731 ! This subroutine calculates the excluded-volume interaction energy between
14732 ! peptide-group centers and side chains and its gradient in virtual-bond and
14733 ! side-chain vectors.
14734 !
14735 !      implicit real*8 (a-h,o-z)
14736 !      include 'DIMENSIONS'
14737 !      include 'COMMON.GEO'
14738 !      include 'COMMON.VAR'
14739 !      include 'COMMON.LOCAL'
14740 !      include 'COMMON.CHAIN'
14741 !      include 'COMMON.DERIV'
14742 !      include 'COMMON.INTERACT'
14743 !      include 'COMMON.FFIELD'
14744 !      include 'COMMON.IOUNITS'
14745 !      include 'COMMON.CONTROL'
14746       real(kind=8),dimension(3) :: ggg
14747 !el local variables
14748       integer :: i,iint,j,k,iteli,itypj,subchap
14749       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
14750       real(kind=8) :: evdw2,evdw2_14,evdwij
14751       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14752                     dist_temp, dist_init
14753
14754       evdw2=0.0D0
14755       evdw2_14=0.0d0
14756 !d    print '(a)','Enter ESCP'
14757 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
14758       do i=iatscp_s,iatscp_e
14759         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
14760         iteli=itel(i)
14761         xi=0.5D0*(c(1,i)+c(1,i+1))
14762         yi=0.5D0*(c(2,i)+c(2,i+1))
14763         zi=0.5D0*(c(3,i)+c(3,i+1))
14764           xi=mod(xi,boxxsize)
14765           if (xi.lt.0) xi=xi+boxxsize
14766           yi=mod(yi,boxysize)
14767           if (yi.lt.0) yi=yi+boxysize
14768           zi=mod(zi,boxzsize)
14769           if (zi.lt.0) zi=zi+boxzsize
14770
14771         do iint=1,nscp_gr(i)
14772
14773         do j=iscpstart(i,iint),iscpend(i,iint)
14774           itypj=itype(j)
14775           if (itypj.eq.ntyp1) cycle
14776 ! Uncomment following three lines for SC-p interactions
14777 !         xj=c(1,nres+j)-xi
14778 !         yj=c(2,nres+j)-yi
14779 !         zj=c(3,nres+j)-zi
14780 ! Uncomment following three lines for Ca-p interactions
14781 !          xj=c(1,j)-xi
14782 !          yj=c(2,j)-yi
14783 !          zj=c(3,j)-zi
14784           xj=c(1,j)
14785           yj=c(2,j)
14786           zj=c(3,j)
14787           xj=mod(xj,boxxsize)
14788           if (xj.lt.0) xj=xj+boxxsize
14789           yj=mod(yj,boxysize)
14790           if (yj.lt.0) yj=yj+boxysize
14791           zj=mod(zj,boxzsize)
14792           if (zj.lt.0) zj=zj+boxzsize
14793       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14794       xj_safe=xj
14795       yj_safe=yj
14796       zj_safe=zj
14797       subchap=0
14798       do xshift=-1,1
14799       do yshift=-1,1
14800       do zshift=-1,1
14801           xj=xj_safe+xshift*boxxsize
14802           yj=yj_safe+yshift*boxysize
14803           zj=zj_safe+zshift*boxzsize
14804           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14805           if(dist_temp.lt.dist_init) then
14806             dist_init=dist_temp
14807             xj_temp=xj
14808             yj_temp=yj
14809             zj_temp=zj
14810             subchap=1
14811           endif
14812        enddo
14813        enddo
14814        enddo
14815        if (subchap.eq.1) then
14816           xj=xj_temp-xi
14817           yj=yj_temp-yi
14818           zj=zj_temp-zi
14819        else
14820           xj=xj_safe-xi
14821           yj=yj_safe-yi
14822           zj=zj_safe-zi
14823        endif
14824
14825           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14826           rij=dsqrt(1.0d0/rrij)
14827             sss_ele_cut=sscale_ele(rij)
14828             sss_ele_grad=sscagrad_ele(rij)
14829 !            print *,sss_ele_cut,sss_ele_grad,&
14830 !            (rij),r_cut_ele,rlamb_ele
14831             if (sss_ele_cut.le.0.0) cycle
14832           sss=sscale(rij/rscp(itypj,iteli))
14833           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
14834           if (sss.gt.0.0d0) then
14835
14836             fac=rrij**expon2
14837             e1=fac*fac*aad(itypj,iteli)
14838             e2=fac*bad(itypj,iteli)
14839             if (iabs(j-i) .le. 2) then
14840               e1=scal14*e1
14841               e2=scal14*e2
14842               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
14843             endif
14844             evdwij=e1+e2
14845             evdw2=evdw2+evdwij*sss*sss_ele_cut
14846             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
14847                 'evdw2',i,j,sss,evdwij
14848 !
14849 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
14850 !
14851             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
14852             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
14853             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
14854
14855             ggg(1)=xj*fac
14856             ggg(2)=yj*fac
14857             ggg(3)=zj*fac
14858 ! Uncomment following three lines for SC-p interactions
14859 !           do k=1,3
14860 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14861 !           enddo
14862 ! Uncomment following line for SC-p interactions
14863 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14864             do k=1,3
14865               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
14866               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
14867             enddo
14868           endif
14869         enddo
14870
14871         enddo ! iint
14872       enddo ! i
14873       do i=1,nct
14874         do j=1,3
14875           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
14876           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
14877           gradx_scp(j,i)=expon*gradx_scp(j,i)
14878         enddo
14879       enddo
14880 !******************************************************************************
14881 !
14882 !                              N O T E !!!
14883 !
14884 ! To save time the factor EXPON has been extracted from ALL components
14885 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14886 ! use!
14887 !
14888 !******************************************************************************
14889       return
14890       end subroutine escp_short
14891 !-----------------------------------------------------------------------------
14892 ! energy_p_new-sep_barrier.F
14893 !-----------------------------------------------------------------------------
14894       subroutine sc_grad_scale(scalfac)
14895 !      implicit real*8 (a-h,o-z)
14896       use calc_data
14897 !      include 'DIMENSIONS'
14898 !      include 'COMMON.CHAIN'
14899 !      include 'COMMON.DERIV'
14900 !      include 'COMMON.CALC'
14901 !      include 'COMMON.IOUNITS'
14902       real(kind=8),dimension(3) :: dcosom1,dcosom2
14903       real(kind=8) :: scalfac
14904 !el local variables
14905 !      integer :: i,j,k,l
14906
14907       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
14908       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
14909       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
14910            -2.0D0*alf12*eps3der+sigder*sigsq_om12
14911 ! diagnostics only
14912 !      eom1=0.0d0
14913 !      eom2=0.0d0
14914 !      eom12=evdwij*eps1_om12
14915 ! end diagnostics
14916 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
14917 !     &  " sigder",sigder
14918 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
14919 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
14920       do k=1,3
14921         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
14922         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
14923       enddo
14924       do k=1,3
14925         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
14926          *sss_ele_cut
14927       enddo
14928 !      write (iout,*) "gg",(gg(k),k=1,3)
14929       do k=1,3
14930         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
14931                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
14932                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
14933                  *sss_ele_cut
14934         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
14935                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
14936                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
14937          *sss_ele_cut
14938 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
14939 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
14940 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
14941 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
14942       enddo
14943 !
14944 ! Calculate the components of the gradient in DC and X
14945 !
14946       do l=1,3
14947         gvdwc(l,i)=gvdwc(l,i)-gg(l)
14948         gvdwc(l,j)=gvdwc(l,j)+gg(l)
14949       enddo
14950       return
14951       end subroutine sc_grad_scale
14952 !-----------------------------------------------------------------------------
14953 ! energy_split-sep.F
14954 !-----------------------------------------------------------------------------
14955       subroutine etotal_long(energia)
14956 !
14957 ! Compute the long-range slow-varying contributions to the energy
14958 !
14959 !      implicit real*8 (a-h,o-z)
14960 !      include 'DIMENSIONS'
14961       use MD_data, only: totT,usampl,eq_time
14962 #ifndef ISNAN
14963       external proc_proc
14964 #ifdef WINPGI
14965 !MS$ATTRIBUTES C ::  proc_proc
14966 #endif
14967 #endif
14968 #ifdef MPI
14969       include "mpif.h"
14970       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
14971 #endif
14972 !      include 'COMMON.SETUP'
14973 !      include 'COMMON.IOUNITS'
14974 !      include 'COMMON.FFIELD'
14975 !      include 'COMMON.DERIV'
14976 !      include 'COMMON.INTERACT'
14977 !      include 'COMMON.SBRIDGE'
14978 !      include 'COMMON.CHAIN'
14979 !      include 'COMMON.VAR'
14980 !      include 'COMMON.LOCAL'
14981 !      include 'COMMON.MD'
14982       real(kind=8),dimension(0:n_ene) :: energia
14983 !el local variables
14984       integer :: i,n_corr,n_corr1,ierror,ierr
14985       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
14986                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
14987                   ecorr,ecorr5,ecorr6,eturn6,time00
14988 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
14989 !elwrite(iout,*)"in etotal long"
14990
14991       if (modecalc.eq.12.or.modecalc.eq.14) then
14992 #ifdef MPI
14993 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
14994 #else
14995         call int_from_cart1(.false.)
14996 #endif
14997       endif
14998 !elwrite(iout,*)"in etotal long"
14999
15000 #ifdef MPI
15001 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15002 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15003       call flush(iout)
15004       if (nfgtasks.gt.1) then
15005         time00=MPI_Wtime()
15006 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15007         if (fg_rank.eq.0) then
15008           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15009 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15010 !          call flush(iout)
15011 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15012 ! FG slaves as WEIGHTS array.
15013           weights_(1)=wsc
15014           weights_(2)=wscp
15015           weights_(3)=welec
15016           weights_(4)=wcorr
15017           weights_(5)=wcorr5
15018           weights_(6)=wcorr6
15019           weights_(7)=wel_loc
15020           weights_(8)=wturn3
15021           weights_(9)=wturn4
15022           weights_(10)=wturn6
15023           weights_(11)=wang
15024           weights_(12)=wscloc
15025           weights_(13)=wtor
15026           weights_(14)=wtor_d
15027           weights_(15)=wstrain
15028           weights_(16)=wvdwpp
15029           weights_(17)=wbond
15030           weights_(18)=scal14
15031           weights_(21)=wsccor
15032 ! FG Master broadcasts the WEIGHTS_ array
15033           call MPI_Bcast(weights_(1),n_ene,&
15034               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15035         else
15036 ! FG slaves receive the WEIGHTS array
15037           call MPI_Bcast(weights(1),n_ene,&
15038               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15039           wsc=weights(1)
15040           wscp=weights(2)
15041           welec=weights(3)
15042           wcorr=weights(4)
15043           wcorr5=weights(5)
15044           wcorr6=weights(6)
15045           wel_loc=weights(7)
15046           wturn3=weights(8)
15047           wturn4=weights(9)
15048           wturn6=weights(10)
15049           wang=weights(11)
15050           wscloc=weights(12)
15051           wtor=weights(13)
15052           wtor_d=weights(14)
15053           wstrain=weights(15)
15054           wvdwpp=weights(16)
15055           wbond=weights(17)
15056           scal14=weights(18)
15057           wsccor=weights(21)
15058         endif
15059         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15060           king,FG_COMM,IERR)
15061          time_Bcast=time_Bcast+MPI_Wtime()-time00
15062          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15063 !        call chainbuild_cart
15064 !        call int_from_cart1(.false.)
15065       endif
15066 !      write (iout,*) 'Processor',myrank,
15067 !     &  ' calling etotal_short ipot=',ipot
15068 !      call flush(iout)
15069 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15070 #endif
15071 !d    print *,'nnt=',nnt,' nct=',nct
15072 !
15073 !elwrite(iout,*)"in etotal long"
15074 ! Compute the side-chain and electrostatic interaction energy
15075 !
15076       goto (101,102,103,104,105,106) ipot
15077 ! Lennard-Jones potential.
15078   101 call elj_long(evdw)
15079 !d    print '(a)','Exit ELJ'
15080       goto 107
15081 ! Lennard-Jones-Kihara potential (shifted).
15082   102 call eljk_long(evdw)
15083       goto 107
15084 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15085   103 call ebp_long(evdw)
15086       goto 107
15087 ! Gay-Berne potential (shifted LJ, angular dependence).
15088   104 call egb_long(evdw)
15089       goto 107
15090 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15091   105 call egbv_long(evdw)
15092       goto 107
15093 ! Soft-sphere potential
15094   106 call e_softsphere(evdw)
15095 !
15096 ! Calculate electrostatic (H-bonding) energy of the main chain.
15097 !
15098   107 continue
15099       call vec_and_deriv
15100       if (ipot.lt.6) then
15101 #ifdef SPLITELE
15102          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15103              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15104              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15105              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15106 #else
15107          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15108              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15109              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15110              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15111 #endif
15112            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15113          else
15114             ees=0
15115             evdw1=0
15116             eel_loc=0
15117             eello_turn3=0
15118             eello_turn4=0
15119          endif
15120       else
15121 !        write (iout,*) "Soft-spheer ELEC potential"
15122         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15123          eello_turn4)
15124       endif
15125 !
15126 ! Calculate excluded-volume interaction energy between peptide groups
15127 ! and side chains.
15128 !
15129       if (ipot.lt.6) then
15130        if(wscp.gt.0d0) then
15131         call escp_long(evdw2,evdw2_14)
15132        else
15133         evdw2=0
15134         evdw2_14=0
15135        endif
15136       else
15137         call escp_soft_sphere(evdw2,evdw2_14)
15138       endif
15139 !
15140 ! 12/1/95 Multi-body terms
15141 !
15142       n_corr=0
15143       n_corr1=0
15144       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15145           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15146          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15147 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15148 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15149       else
15150          ecorr=0.0d0
15151          ecorr5=0.0d0
15152          ecorr6=0.0d0
15153          eturn6=0.0d0
15154       endif
15155       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15156          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15157       endif
15158 !
15159 ! If performing constraint dynamics, call the constraint energy
15160 !  after the equilibration time
15161       if(usampl.and.totT.gt.eq_time) then
15162          call EconstrQ
15163          call Econstr_back
15164       else
15165          Uconst=0.0d0
15166          Uconst_back=0.0d0
15167       endif
15168 !
15169 ! Sum the energies
15170 !
15171       do i=1,n_ene
15172         energia(i)=0.0d0
15173       enddo
15174       energia(1)=evdw
15175 #ifdef SCP14
15176       energia(2)=evdw2-evdw2_14
15177       energia(18)=evdw2_14
15178 #else
15179       energia(2)=evdw2
15180       energia(18)=0.0d0
15181 #endif
15182 #ifdef SPLITELE
15183       energia(3)=ees
15184       energia(16)=evdw1
15185 #else
15186       energia(3)=ees+evdw1
15187       energia(16)=0.0d0
15188 #endif
15189       energia(4)=ecorr
15190       energia(5)=ecorr5
15191       energia(6)=ecorr6
15192       energia(7)=eel_loc
15193       energia(8)=eello_turn3
15194       energia(9)=eello_turn4
15195       energia(10)=eturn6
15196       energia(20)=Uconst+Uconst_back
15197       call sum_energy(energia,.true.)
15198 !      write (iout,*) "Exit ETOTAL_LONG"
15199       call flush(iout)
15200       return
15201       end subroutine etotal_long
15202 !-----------------------------------------------------------------------------
15203       subroutine etotal_short(energia)
15204 !
15205 ! Compute the short-range fast-varying contributions to the energy
15206 !
15207 !      implicit real*8 (a-h,o-z)
15208 !      include 'DIMENSIONS'
15209 #ifndef ISNAN
15210       external proc_proc
15211 #ifdef WINPGI
15212 !MS$ATTRIBUTES C ::  proc_proc
15213 #endif
15214 #endif
15215 #ifdef MPI
15216       include "mpif.h"
15217       integer :: ierror,ierr
15218       real(kind=8),dimension(n_ene) :: weights_
15219       real(kind=8) :: time00
15220 #endif
15221 !      include 'COMMON.SETUP'
15222 !      include 'COMMON.IOUNITS'
15223 !      include 'COMMON.FFIELD'
15224 !      include 'COMMON.DERIV'
15225 !      include 'COMMON.INTERACT'
15226 !      include 'COMMON.SBRIDGE'
15227 !      include 'COMMON.CHAIN'
15228 !      include 'COMMON.VAR'
15229 !      include 'COMMON.LOCAL'
15230       real(kind=8),dimension(0:n_ene) :: energia
15231 !el local variables
15232       integer :: i,nres6
15233       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15234       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr
15235       nres6=6*nres
15236
15237 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15238 !      call flush(iout)
15239       if (modecalc.eq.12.or.modecalc.eq.14) then
15240 #ifdef MPI
15241         if (fg_rank.eq.0) call int_from_cart1(.false.)
15242 #else
15243         call int_from_cart1(.false.)
15244 #endif
15245       endif
15246 #ifdef MPI
15247 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15248 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15249 !      call flush(iout)
15250       if (nfgtasks.gt.1) then
15251         time00=MPI_Wtime()
15252 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15253         if (fg_rank.eq.0) then
15254           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15255 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15256 !          call flush(iout)
15257 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15258 ! FG slaves as WEIGHTS array.
15259           weights_(1)=wsc
15260           weights_(2)=wscp
15261           weights_(3)=welec
15262           weights_(4)=wcorr
15263           weights_(5)=wcorr5
15264           weights_(6)=wcorr6
15265           weights_(7)=wel_loc
15266           weights_(8)=wturn3
15267           weights_(9)=wturn4
15268           weights_(10)=wturn6
15269           weights_(11)=wang
15270           weights_(12)=wscloc
15271           weights_(13)=wtor
15272           weights_(14)=wtor_d
15273           weights_(15)=wstrain
15274           weights_(16)=wvdwpp
15275           weights_(17)=wbond
15276           weights_(18)=scal14
15277           weights_(21)=wsccor
15278 ! FG Master broadcasts the WEIGHTS_ array
15279           call MPI_Bcast(weights_(1),n_ene,&
15280               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15281         else
15282 ! FG slaves receive the WEIGHTS array
15283           call MPI_Bcast(weights(1),n_ene,&
15284               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15285           wsc=weights(1)
15286           wscp=weights(2)
15287           welec=weights(3)
15288           wcorr=weights(4)
15289           wcorr5=weights(5)
15290           wcorr6=weights(6)
15291           wel_loc=weights(7)
15292           wturn3=weights(8)
15293           wturn4=weights(9)
15294           wturn6=weights(10)
15295           wang=weights(11)
15296           wscloc=weights(12)
15297           wtor=weights(13)
15298           wtor_d=weights(14)
15299           wstrain=weights(15)
15300           wvdwpp=weights(16)
15301           wbond=weights(17)
15302           scal14=weights(18)
15303           wsccor=weights(21)
15304         endif
15305 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15306         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15307           king,FG_COMM,IERR)
15308 !        write (iout,*) "Processor",myrank," BROADCAST c"
15309         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15310           king,FG_COMM,IERR)
15311 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15312         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15313           king,FG_COMM,IERR)
15314 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15315         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15316           king,FG_COMM,IERR)
15317 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15318         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15319           king,FG_COMM,IERR)
15320 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15321         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15322           king,FG_COMM,IERR)
15323 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15324         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15325           king,FG_COMM,IERR)
15326 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15327         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15328           king,FG_COMM,IERR)
15329 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15330         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15331           king,FG_COMM,IERR)
15332          time_Bcast=time_Bcast+MPI_Wtime()-time00
15333 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15334       endif
15335 !      write (iout,*) 'Processor',myrank,
15336 !     &  ' calling etotal_short ipot=',ipot
15337 !      call flush(iout)
15338 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15339 #endif
15340 !      call int_from_cart1(.false.)
15341 !
15342 ! Compute the side-chain and electrostatic interaction energy
15343 !
15344       goto (101,102,103,104,105,106) ipot
15345 ! Lennard-Jones potential.
15346   101 call elj_short(evdw)
15347 !d    print '(a)','Exit ELJ'
15348       goto 107
15349 ! Lennard-Jones-Kihara potential (shifted).
15350   102 call eljk_short(evdw)
15351       goto 107
15352 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15353   103 call ebp_short(evdw)
15354       goto 107
15355 ! Gay-Berne potential (shifted LJ, angular dependence).
15356   104 call egb_short(evdw)
15357       goto 107
15358 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15359   105 call egbv_short(evdw)
15360       goto 107
15361 ! Soft-sphere potential - already dealt with in the long-range part
15362   106 evdw=0.0d0
15363 !  106 call e_softsphere_short(evdw)
15364 !
15365 ! Calculate electrostatic (H-bonding) energy of the main chain.
15366 !
15367   107 continue
15368 !
15369 ! Calculate the short-range part of Evdwpp
15370 !
15371       call evdwpp_short(evdw1)
15372 !
15373 ! Calculate the short-range part of ESCp
15374 !
15375       if (ipot.lt.6) then
15376         call escp_short(evdw2,evdw2_14)
15377       endif
15378 !
15379 ! Calculate the bond-stretching energy
15380 !
15381       call ebond(estr)
15382 !
15383 ! Calculate the disulfide-bridge and other energy and the contributions
15384 ! from other distance constraints.
15385       call edis(ehpb)
15386 !
15387 ! Calculate the virtual-bond-angle energy.
15388 !
15389       call ebend(ebe)
15390 !
15391 ! Calculate the SC local energy.
15392 !
15393       call vec_and_deriv
15394       call esc(escloc)
15395 !
15396 ! Calculate the virtual-bond torsional energy.
15397 !
15398       call etor(etors,edihcnstr)
15399 !
15400 ! 6/23/01 Calculate double-torsional energy
15401 !
15402       call etor_d(etors_d)
15403 !
15404 ! 21/5/07 Calculate local sicdechain correlation energy
15405 !
15406       if (wsccor.gt.0.0d0) then
15407         call eback_sc_corr(esccor)
15408       else
15409         esccor=0.0d0
15410       endif
15411 !
15412 ! Put energy components into an array
15413 !
15414       do i=1,n_ene
15415         energia(i)=0.0d0
15416       enddo
15417       energia(1)=evdw
15418 #ifdef SCP14
15419       energia(2)=evdw2-evdw2_14
15420       energia(18)=evdw2_14
15421 #else
15422       energia(2)=evdw2
15423       energia(18)=0.0d0
15424 #endif
15425 #ifdef SPLITELE
15426       energia(16)=evdw1
15427 #else
15428       energia(3)=evdw1
15429 #endif
15430       energia(11)=ebe
15431       energia(12)=escloc
15432       energia(13)=etors
15433       energia(14)=etors_d
15434       energia(15)=ehpb
15435       energia(17)=estr
15436       energia(19)=edihcnstr
15437       energia(21)=esccor
15438 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15439       call flush(iout)
15440       call sum_energy(energia,.true.)
15441 !      write (iout,*) "Exit ETOTAL_SHORT"
15442       call flush(iout)
15443       return
15444       end subroutine etotal_short
15445 !-----------------------------------------------------------------------------
15446 ! gnmr1.f
15447 !-----------------------------------------------------------------------------
15448       real(kind=8) function gnmr1(y,ymin,ymax)
15449 !      implicit none
15450       real(kind=8) :: y,ymin,ymax
15451       real(kind=8) :: wykl=4.0d0
15452       if (y.lt.ymin) then
15453         gnmr1=(ymin-y)**wykl/wykl
15454       else if (y.gt.ymax) then
15455         gnmr1=(y-ymax)**wykl/wykl
15456       else
15457         gnmr1=0.0d0
15458       endif
15459       return
15460       end function gnmr1
15461 !-----------------------------------------------------------------------------
15462       real(kind=8) function gnmr1prim(y,ymin,ymax)
15463 !      implicit none
15464       real(kind=8) :: y,ymin,ymax
15465       real(kind=8) :: wykl=4.0d0
15466       if (y.lt.ymin) then
15467         gnmr1prim=-(ymin-y)**(wykl-1)
15468       else if (y.gt.ymax) then
15469         gnmr1prim=(y-ymax)**(wykl-1)
15470       else
15471         gnmr1prim=0.0d0
15472       endif
15473       return
15474       end function gnmr1prim
15475 !-----------------------------------------------------------------------------
15476       real(kind=8) function harmonic(y,ymax)
15477 !      implicit none
15478       real(kind=8) :: y,ymax
15479       real(kind=8) :: wykl=2.0d0
15480       harmonic=(y-ymax)**wykl
15481       return
15482       end function harmonic
15483 !-----------------------------------------------------------------------------
15484       real(kind=8) function harmonicprim(y,ymax)
15485       real(kind=8) :: y,ymin,ymax
15486       real(kind=8) :: wykl=2.0d0
15487       harmonicprim=(y-ymax)*wykl
15488       return
15489       end function harmonicprim
15490 !-----------------------------------------------------------------------------
15491 ! gradient_p.F
15492 !-----------------------------------------------------------------------------
15493       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
15494
15495       use io_base, only:intout,briefout
15496 !      implicit real*8 (a-h,o-z)
15497 !      include 'DIMENSIONS'
15498 !      include 'COMMON.CHAIN'
15499 !      include 'COMMON.DERIV'
15500 !      include 'COMMON.VAR'
15501 !      include 'COMMON.INTERACT'
15502 !      include 'COMMON.FFIELD'
15503 !      include 'COMMON.MD'
15504 !      include 'COMMON.IOUNITS'
15505       real(kind=8),external :: ufparm
15506       integer :: uiparm(1)
15507       real(kind=8) :: urparm(1)
15508       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
15509       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
15510       integer :: n,nf,ind,ind1,i,k,j
15511 !
15512 ! This subroutine calculates total internal coordinate gradient.
15513 ! Depending on the number of function evaluations, either whole energy
15514 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
15515 ! internal coordinates are reevaluated or only the cartesian-in-internal
15516 ! coordinate derivatives are evaluated. The subroutine was designed to work
15517 ! with SUMSL.
15518 !
15519 !
15520       icg=mod(nf,2)+1
15521
15522 !d      print *,'grad',nf,icg
15523       if (nf-nfl+1) 20,30,40
15524    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
15525 !    write (iout,*) 'grad 20'
15526       if (nf.eq.0) return
15527       goto 40
15528    30 call var_to_geom(n,x)
15529       call chainbuild
15530 !    write (iout,*) 'grad 30'
15531 !
15532 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
15533 !
15534    40 call cartder
15535 !     write (iout,*) 'grad 40'
15536 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
15537 !
15538 ! Convert the Cartesian gradient into internal-coordinate gradient.
15539 !
15540       ind=0
15541       ind1=0
15542       do i=1,nres-2
15543         gthetai=0.0D0
15544         gphii=0.0D0
15545         do j=i+1,nres-1
15546           ind=ind+1
15547 !         ind=indmat(i,j)
15548 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
15549           do k=1,3
15550             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
15551           enddo
15552           do k=1,3
15553             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
15554           enddo
15555         enddo
15556         do j=i+1,nres-1
15557           ind1=ind1+1
15558 !         ind1=indmat(i,j)
15559 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
15560           do k=1,3
15561             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
15562             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
15563           enddo
15564         enddo
15565         if (i.gt.1) g(i-1)=gphii
15566         if (n.gt.nphi) g(nphi+i)=gthetai
15567       enddo
15568       if (n.le.nphi+ntheta) goto 10
15569       do i=2,nres-1
15570         if (itype(i).ne.10) then
15571           galphai=0.0D0
15572           gomegai=0.0D0
15573           do k=1,3
15574             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
15575           enddo
15576           do k=1,3
15577             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
15578           enddo
15579           g(ialph(i,1))=galphai
15580           g(ialph(i,1)+nside)=gomegai
15581         endif
15582       enddo
15583 !
15584 ! Add the components corresponding to local energy terms.
15585 !
15586    10 continue
15587       do i=1,nvar
15588 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
15589         g(i)=g(i)+gloc(i,icg)
15590       enddo
15591 ! Uncomment following three lines for diagnostics.
15592 !d    call intout
15593 !elwrite(iout,*) "in gradient after calling intout"
15594 !d    call briefout(0,0.0d0)
15595 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
15596       return
15597       end subroutine gradient
15598 !-----------------------------------------------------------------------------
15599       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
15600
15601       use comm_chu
15602 !      implicit real*8 (a-h,o-z)
15603 !      include 'DIMENSIONS'
15604 !      include 'COMMON.DERIV'
15605 !      include 'COMMON.IOUNITS'
15606 !      include 'COMMON.GEO'
15607       integer :: n,nf
15608 !el      integer :: jjj
15609 !el      common /chuju/ jjj
15610       real(kind=8) :: energia(0:n_ene)
15611       integer :: uiparm(1)
15612       real(kind=8) :: urparm(1)
15613       real(kind=8) :: f
15614       real(kind=8),external :: ufparm
15615       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
15616 !     if (jjj.gt.0) then
15617 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15618 !     endif
15619       nfl=nf
15620       icg=mod(nf,2)+1
15621 !d      print *,'func',nf,nfl,icg
15622       call var_to_geom(n,x)
15623       call zerograd
15624       call chainbuild
15625 !d    write (iout,*) 'ETOTAL called from FUNC'
15626       call etotal(energia)
15627       call sum_gradient
15628       f=energia(0)
15629 !     if (jjj.gt.0) then
15630 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15631 !       write (iout,*) 'f=',etot
15632 !       jjj=0
15633 !     endif
15634       return
15635       end subroutine func
15636 !-----------------------------------------------------------------------------
15637       subroutine cartgrad
15638 !      implicit real*8 (a-h,o-z)
15639 !      include 'DIMENSIONS'
15640       use energy_data
15641       use MD_data, only: totT,usampl,eq_time
15642 #ifdef MPI
15643       include 'mpif.h'
15644 #endif
15645 !      include 'COMMON.CHAIN'
15646 !      include 'COMMON.DERIV'
15647 !      include 'COMMON.VAR'
15648 !      include 'COMMON.INTERACT'
15649 !      include 'COMMON.FFIELD'
15650 !      include 'COMMON.MD'
15651 !      include 'COMMON.IOUNITS'
15652 !      include 'COMMON.TIME1'
15653 !
15654       integer :: i,j
15655
15656 ! This subrouting calculates total Cartesian coordinate gradient.
15657 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
15658 !
15659 !el#define DEBUG
15660 #ifdef TIMING
15661       time00=MPI_Wtime()
15662 #endif
15663       icg=1
15664       call sum_gradient
15665 #ifdef TIMING
15666 #endif
15667 !el      write (iout,*) "After sum_gradient"
15668 #ifdef DEBUG
15669 !el      write (iout,*) "After sum_gradient"
15670       do i=1,nres-1
15671         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
15672         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
15673       enddo
15674 #endif
15675 ! If performing constraint dynamics, add the gradients of the constraint energy
15676       if(usampl.and.totT.gt.eq_time) then
15677          do i=1,nct
15678            do j=1,3
15679              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
15680              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
15681            enddo
15682          enddo
15683          do i=1,nres-3
15684            gloc(i,icg)=gloc(i,icg)+dugamma(i)
15685          enddo
15686          do i=1,nres-2
15687            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
15688          enddo
15689       endif
15690 !elwrite (iout,*) "After sum_gradient"
15691 #ifdef TIMING
15692       time01=MPI_Wtime()
15693 #endif
15694       call intcartderiv
15695 !elwrite (iout,*) "After sum_gradient"
15696 #ifdef TIMING
15697       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
15698 #endif
15699 !     call checkintcartgrad
15700 !     write(iout,*) 'calling int_to_cart'
15701 #ifdef DEBUG
15702       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
15703 #endif
15704       do i=0,nct
15705         do j=1,3
15706           gcart(j,i)=gradc(j,i,icg)
15707           gxcart(j,i)=gradx(j,i,icg)
15708         enddo
15709 #ifdef DEBUG
15710         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
15711           (gxcart(j,i),j=1,3),gloc(i,icg)
15712 #endif
15713       enddo
15714 #ifdef TIMING
15715       time01=MPI_Wtime()
15716 #endif
15717       call int_to_cart
15718 #ifdef TIMING
15719       time_inttocart=time_inttocart+MPI_Wtime()-time01
15720 #endif
15721 #ifdef DEBUG
15722       write (iout,*) "gcart and gxcart after int_to_cart"
15723       do i=0,nres-1
15724         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
15725             (gxcart(j,i),j=1,3)
15726       enddo
15727 #endif
15728 #ifdef CARGRAD
15729 #ifdef DEBUG
15730       write (iout,*) "CARGRAD"
15731 #endif
15732       do i=nres,0,-1
15733         do j=1,3
15734           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
15735 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
15736         enddo
15737 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
15738 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
15739       enddo
15740 ! Correction: dummy residues
15741         if (nnt.gt.1) then
15742           do j=1,3
15743 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
15744             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
15745           enddo
15746         endif
15747         if (nct.lt.nres) then
15748           do j=1,3
15749 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
15750             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
15751           enddo
15752         endif
15753 #endif
15754 #ifdef TIMING
15755       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
15756 #endif
15757 !el#undef DEBUG
15758       return
15759       end subroutine cartgrad
15760 !-----------------------------------------------------------------------------
15761       subroutine zerograd
15762 !      implicit real*8 (a-h,o-z)
15763 !      include 'DIMENSIONS'
15764 !      include 'COMMON.DERIV'
15765 !      include 'COMMON.CHAIN'
15766 !      include 'COMMON.VAR'
15767 !      include 'COMMON.MD'
15768 !      include 'COMMON.SCCOR'
15769 !
15770 !el local variables
15771       integer :: i,j,intertyp,k
15772 ! Initialize Cartesian-coordinate gradient
15773 !
15774 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
15775 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
15776
15777 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
15778 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
15779 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
15780 !      allocate(gradcorr_long(3,nres))
15781 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
15782 !      allocate(gcorr6_turn_long(3,nres))
15783 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
15784
15785 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
15786
15787 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
15788 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
15789
15790 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
15791 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
15792
15793 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
15794 !      allocate(gscloc(3,nres)) !(3,maxres)
15795 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
15796
15797
15798
15799 !      common /deriv_scloc/
15800 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
15801 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
15802 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
15803 !      common /mpgrad/
15804 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
15805
15806
15807
15808 !          gradc(j,i,icg)=0.0d0
15809 !          gradx(j,i,icg)=0.0d0
15810
15811 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
15812 !elwrite(iout,*) "icg",icg
15813       do i=-1,nres
15814         do j=1,3
15815           gvdwx(j,i)=0.0D0
15816           gradx_scp(j,i)=0.0D0
15817           gvdwc(j,i)=0.0D0
15818           gvdwc_scp(j,i)=0.0D0
15819           gvdwc_scpp(j,i)=0.0d0
15820           gelc(j,i)=0.0D0
15821           gelc_long(j,i)=0.0D0
15822           gradb(j,i)=0.0d0
15823           gradbx(j,i)=0.0d0
15824           gvdwpp(j,i)=0.0d0
15825           gel_loc(j,i)=0.0d0
15826           gel_loc_long(j,i)=0.0d0
15827           ghpbc(j,i)=0.0D0
15828           ghpbx(j,i)=0.0D0
15829           gcorr3_turn(j,i)=0.0d0
15830           gcorr4_turn(j,i)=0.0d0
15831           gradcorr(j,i)=0.0d0
15832           gradcorr_long(j,i)=0.0d0
15833           gradcorr5_long(j,i)=0.0d0
15834           gradcorr6_long(j,i)=0.0d0
15835           gcorr6_turn_long(j,i)=0.0d0
15836           gradcorr5(j,i)=0.0d0
15837           gradcorr6(j,i)=0.0d0
15838           gcorr6_turn(j,i)=0.0d0
15839           gsccorc(j,i)=0.0d0
15840           gsccorx(j,i)=0.0d0
15841           gradc(j,i,icg)=0.0d0
15842           gradx(j,i,icg)=0.0d0
15843           gscloc(j,i)=0.0d0
15844           gsclocx(j,i)=0.0d0
15845           gliptran(j,i)=0.0d0
15846           gliptranx(j,i)=0.0d0
15847           gliptranc(j,i)=0.0d0
15848           gshieldx(j,i)=0.0d0
15849           gshieldc(j,i)=0.0d0
15850           gshieldc_loc(j,i)=0.0d0
15851           gshieldx_ec(j,i)=0.0d0
15852           gshieldc_ec(j,i)=0.0d0
15853           gshieldc_loc_ec(j,i)=0.0d0
15854           gshieldx_t3(j,i)=0.0d0
15855           gshieldc_t3(j,i)=0.0d0
15856           gshieldc_loc_t3(j,i)=0.0d0
15857           gshieldx_t4(j,i)=0.0d0
15858           gshieldc_t4(j,i)=0.0d0
15859           gshieldc_loc_t4(j,i)=0.0d0
15860           gshieldx_ll(j,i)=0.0d0
15861           gshieldc_ll(j,i)=0.0d0
15862           gshieldc_loc_ll(j,i)=0.0d0
15863
15864           do intertyp=1,3
15865            gloc_sc(intertyp,i,icg)=0.0d0
15866           enddo
15867         enddo
15868       enddo
15869       do i=1,nres
15870        do j=1,maxcontsshi
15871        shield_list(j,i)=0
15872         do k=1,3
15873 !C           print *,i,j,k
15874            grad_shield_side(k,j,i)=0.0d0
15875            grad_shield_loc(k,j,i)=0.0d0
15876          enddo
15877        enddo
15878        ishield_list(i)=0
15879       enddo
15880
15881 !
15882 ! Initialize the gradient of local energy terms.
15883 !
15884 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
15885 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
15886 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
15887 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
15888 !      allocate(gel_loc_turn3(nres))
15889 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
15890 !      allocate(gsccor_loc(nres))       !(maxres)
15891
15892       do i=1,4*nres
15893         gloc(i,icg)=0.0D0
15894       enddo
15895       do i=1,nres
15896         gel_loc_loc(i)=0.0d0
15897         gcorr_loc(i)=0.0d0
15898         g_corr5_loc(i)=0.0d0
15899         g_corr6_loc(i)=0.0d0
15900         gel_loc_turn3(i)=0.0d0
15901         gel_loc_turn4(i)=0.0d0
15902         gel_loc_turn6(i)=0.0d0
15903         gsccor_loc(i)=0.0d0
15904       enddo
15905 ! initialize gcart and gxcart
15906 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
15907       do i=0,nres
15908         do j=1,3
15909           gcart(j,i)=0.0d0
15910           gxcart(j,i)=0.0d0
15911         enddo
15912       enddo
15913       return
15914       end subroutine zerograd
15915 !-----------------------------------------------------------------------------
15916       real(kind=8) function fdum()
15917       fdum=0.0D0
15918       return
15919       end function fdum
15920 !-----------------------------------------------------------------------------
15921 ! intcartderiv.F
15922 !-----------------------------------------------------------------------------
15923       subroutine intcartderiv
15924 !      implicit real*8 (a-h,o-z)
15925 !      include 'DIMENSIONS'
15926 #ifdef MPI
15927       include 'mpif.h'
15928 #endif
15929 !      include 'COMMON.SETUP'
15930 !      include 'COMMON.CHAIN'
15931 !      include 'COMMON.VAR'
15932 !      include 'COMMON.GEO'
15933 !      include 'COMMON.INTERACT'
15934 !      include 'COMMON.DERIV'
15935 !      include 'COMMON.IOUNITS'
15936 !      include 'COMMON.LOCAL'
15937 !      include 'COMMON.SCCOR'
15938       real(kind=8) :: pi4,pi34
15939       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
15940       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
15941                     dcosomega,dsinomega !(3,3,maxres)
15942       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
15943
15944       integer :: i,j,k
15945       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
15946                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
15947                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
15948                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
15949       integer :: nres2
15950       nres2=2*nres
15951
15952 !el from module energy-------------
15953 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
15954 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
15955 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
15956
15957 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
15958 !el      allocate(dsintau(3,3,3,0:nres2))
15959 !el      allocate(dtauangle(3,3,3,0:nres2))
15960 !el      allocate(domicron(3,2,2,0:nres2))
15961 !el      allocate(dcosomicron(3,2,2,0:nres2))
15962
15963
15964
15965 #if defined(MPI) && defined(PARINTDER)
15966       if (nfgtasks.gt.1 .and. me.eq.king) &
15967         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
15968 #endif
15969       pi4 = 0.5d0*pipol
15970       pi34 = 3*pi4
15971
15972 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
15973 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
15974
15975 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
15976       do i=1,nres
15977         do j=1,3
15978           dtheta(j,1,i)=0.0d0
15979           dtheta(j,2,i)=0.0d0
15980           dphi(j,1,i)=0.0d0
15981           dphi(j,2,i)=0.0d0
15982           dphi(j,3,i)=0.0d0
15983         enddo
15984       enddo
15985 ! Derivatives of theta's
15986 #if defined(MPI) && defined(PARINTDER)
15987 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
15988       do i=max0(ithet_start-1,3),ithet_end
15989 #else
15990       do i=3,nres
15991 #endif
15992         cost=dcos(theta(i))
15993         sint=sqrt(1-cost*cost)
15994         do j=1,3
15995           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
15996           vbld(i-1)
15997           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
15998           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
15999           vbld(i)
16000           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16001         enddo
16002       enddo
16003 #if defined(MPI) && defined(PARINTDER)
16004 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16005       do i=max0(ithet_start-1,3),ithet_end
16006 #else
16007       do i=3,nres
16008 #endif
16009       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
16010         cost1=dcos(omicron(1,i))
16011         sint1=sqrt(1-cost1*cost1)
16012         cost2=dcos(omicron(2,i))
16013         sint2=sqrt(1-cost2*cost2)
16014        do j=1,3
16015 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16016           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16017           cost1*dc_norm(j,i-2))/ &
16018           vbld(i-1)
16019           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16020           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16021           +cost1*(dc_norm(j,i-1+nres)))/ &
16022           vbld(i-1+nres)
16023           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16024 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16025 !C Looks messy but better than if in loop
16026           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16027           +cost2*dc_norm(j,i-1))/ &
16028           vbld(i)
16029           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16030           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16031            +cost2*(-dc_norm(j,i-1+nres)))/ &
16032           vbld(i-1+nres)
16033 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
16034           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16035         enddo
16036        endif
16037       enddo
16038 !elwrite(iout,*) "after vbld write"
16039 ! Derivatives of phi:
16040 ! If phi is 0 or 180 degrees, then the formulas
16041 ! have to be derived by power series expansion of the
16042 ! conventional formulas around 0 and 180.
16043 #ifdef PARINTDER
16044       do i=iphi1_start,iphi1_end
16045 #else
16046       do i=4,nres
16047 #endif
16048 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
16049 ! the conventional case
16050         sint=dsin(theta(i))
16051         sint1=dsin(theta(i-1))
16052         sing=dsin(phi(i))
16053         cost=dcos(theta(i))
16054         cost1=dcos(theta(i-1))
16055         cosg=dcos(phi(i))
16056         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16057         fac0=1.0d0/(sint1*sint)
16058         fac1=cost*fac0
16059         fac2=cost1*fac0
16060         fac3=cosg*cost1/(sint1*sint1)
16061         fac4=cosg*cost/(sint*sint)
16062 !    Obtaining the gamma derivatives from sine derivative
16063        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16064            phi(i).gt.pi34.and.phi(i).le.pi.or. &
16065            phi(i).ge.-pi.and.phi(i).le.-pi34) then
16066          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16067          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16068          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16069          do j=1,3
16070             ctgt=cost/sint
16071             ctgt1=cost1/sint1
16072             cosg_inv=1.0d0/cosg
16073             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
16074             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16075               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16076             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16077             dsinphi(j,2,i)= &
16078               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16079               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16080             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16081             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16082               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16083 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16084             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16085             endif
16086 ! Bug fixed 3/24/05 (AL)
16087          enddo
16088 !   Obtaining the gamma derivatives from cosine derivative
16089         else
16090            do j=1,3
16091            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
16092            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16093            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16094            dc_norm(j,i-3))/vbld(i-2)
16095            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16096            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16097            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16098            dcostheta(j,1,i)
16099            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16100            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16101            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16102            dc_norm(j,i-1))/vbld(i)
16103            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16104            endif
16105          enddo
16106         endif
16107       enddo
16108 !alculate derivative of Tauangle
16109 #ifdef PARINTDER
16110       do i=itau_start,itau_end
16111 #else
16112       do i=3,nres
16113 !elwrite(iout,*) " vecpr",i,nres
16114 #endif
16115        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
16116 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
16117 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
16118 !c dtauangle(j,intertyp,dervityp,residue number)
16119 !c INTERTYP=1 SC...Ca...Ca..Ca
16120 ! the conventional case
16121         sint=dsin(theta(i))
16122         sint1=dsin(omicron(2,i-1))
16123         sing=dsin(tauangle(1,i))
16124         cost=dcos(theta(i))
16125         cost1=dcos(omicron(2,i-1))
16126         cosg=dcos(tauangle(1,i))
16127 !elwrite(iout,*) " vecpr5",i,nres
16128         do j=1,3
16129 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16130 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16131         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16132 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16133         enddo
16134         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16135         fac0=1.0d0/(sint1*sint)
16136         fac1=cost*fac0
16137         fac2=cost1*fac0
16138         fac3=cosg*cost1/(sint1*sint1)
16139         fac4=cosg*cost/(sint*sint)
16140 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16141 !    Obtaining the gamma derivatives from sine derivative
16142        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16143            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16144            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16145          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16146          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16147          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16148         do j=1,3
16149             ctgt=cost/sint
16150             ctgt1=cost1/sint1
16151             cosg_inv=1.0d0/cosg
16152             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16153        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16154        *vbld_inv(i-2+nres)
16155             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16156             dsintau(j,1,2,i)= &
16157               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16158               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16159 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16160             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16161 ! Bug fixed 3/24/05 (AL)
16162             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16163               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16164 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16165             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16166          enddo
16167 !   Obtaining the gamma derivatives from cosine derivative
16168         else
16169            do j=1,3
16170            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16171            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16172            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16173            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16174            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16175            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16176            dcostheta(j,1,i)
16177            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16178            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16179            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16180            dc_norm(j,i-1))/vbld(i)
16181            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16182 !         write (iout,*) "else",i
16183          enddo
16184         endif
16185 !        do k=1,3
16186 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16187 !        enddo
16188       enddo
16189 !C Second case Ca...Ca...Ca...SC
16190 #ifdef PARINTDER
16191       do i=itau_start,itau_end
16192 #else
16193       do i=4,nres
16194 #endif
16195        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
16196           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
16197 ! the conventional case
16198         sint=dsin(omicron(1,i))
16199         sint1=dsin(theta(i-1))
16200         sing=dsin(tauangle(2,i))
16201         cost=dcos(omicron(1,i))
16202         cost1=dcos(theta(i-1))
16203         cosg=dcos(tauangle(2,i))
16204 !        do j=1,3
16205 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16206 !        enddo
16207         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16208         fac0=1.0d0/(sint1*sint)
16209         fac1=cost*fac0
16210         fac2=cost1*fac0
16211         fac3=cosg*cost1/(sint1*sint1)
16212         fac4=cosg*cost/(sint*sint)
16213 !    Obtaining the gamma derivatives from sine derivative
16214        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16215            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16216            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16217          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16218          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16219          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16220         do j=1,3
16221             ctgt=cost/sint
16222             ctgt1=cost1/sint1
16223             cosg_inv=1.0d0/cosg
16224             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16225               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16226 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16227 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16228             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16229             dsintau(j,2,2,i)= &
16230               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16231               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16232 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16233 !     & sing*ctgt*domicron(j,1,2,i),
16234 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16235             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16236 ! Bug fixed 3/24/05 (AL)
16237             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16238              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16239 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16240             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16241          enddo
16242 !   Obtaining the gamma derivatives from cosine derivative
16243         else
16244            do j=1,3
16245            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16246            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16247            dc_norm(j,i-3))/vbld(i-2)
16248            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16249            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16250            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16251            dcosomicron(j,1,1,i)
16252            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16253            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16254            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16255            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16256            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16257 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16258          enddo
16259         endif
16260       enddo
16261
16262 !CC third case SC...Ca...Ca...SC
16263 #ifdef PARINTDER
16264
16265       do i=itau_start,itau_end
16266 #else
16267       do i=3,nres
16268 #endif
16269 ! the conventional case
16270       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
16271       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
16272         sint=dsin(omicron(1,i))
16273         sint1=dsin(omicron(2,i-1))
16274         sing=dsin(tauangle(3,i))
16275         cost=dcos(omicron(1,i))
16276         cost1=dcos(omicron(2,i-1))
16277         cosg=dcos(tauangle(3,i))
16278         do j=1,3
16279         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16280 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16281         enddo
16282         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16283         fac0=1.0d0/(sint1*sint)
16284         fac1=cost*fac0
16285         fac2=cost1*fac0
16286         fac3=cosg*cost1/(sint1*sint1)
16287         fac4=cosg*cost/(sint*sint)
16288 !    Obtaining the gamma derivatives from sine derivative
16289        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16290            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16291            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16292          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16293          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16294          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16295         do j=1,3
16296             ctgt=cost/sint
16297             ctgt1=cost1/sint1
16298             cosg_inv=1.0d0/cosg
16299             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16300               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16301               *vbld_inv(i-2+nres)
16302             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16303             dsintau(j,3,2,i)= &
16304               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16305               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16306             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16307 ! Bug fixed 3/24/05 (AL)
16308             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16309               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16310               *vbld_inv(i-1+nres)
16311 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16312             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16313          enddo
16314 !   Obtaining the gamma derivatives from cosine derivative
16315         else
16316            do j=1,3
16317            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16318            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16319            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16320            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16321            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16322            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16323            dcosomicron(j,1,1,i)
16324            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16325            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16326            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16327            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16328            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16329 !          write(iout,*) "else",i
16330          enddo
16331         endif
16332       enddo
16333
16334 #ifdef CRYST_SC
16335 !   Derivatives of side-chain angles alpha and omega
16336 #if defined(MPI) && defined(PARINTDER)
16337         do i=ibond_start,ibond_end
16338 #else
16339         do i=2,nres-1
16340 #endif
16341           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
16342              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16343              fac6=fac5/vbld(i)
16344              fac7=fac5*fac5
16345              fac8=fac5/vbld(i+1)
16346              fac9=fac5/vbld(i+nres)
16347              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16348              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16349              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16350              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16351              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16352              sina=sqrt(1-cosa*cosa)
16353              sino=dsin(omeg(i))
16354 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16355              do j=1,3
16356                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16357                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16358                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16359                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16360                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16361                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16362                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16363                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16364                 vbld(i+nres))
16365                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16366             enddo
16367 ! obtaining the derivatives of omega from sines
16368             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16369                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16370                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16371                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16372                dsin(theta(i+1)))
16373                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16374                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16375                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16376                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16377                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16378                coso_inv=1.0d0/dcos(omeg(i))
16379                do j=1,3
16380                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16381                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16382                  (sino*dc_norm(j,i-1))/vbld(i)
16383                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16384                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16385                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16386                  -sino*dc_norm(j,i)/vbld(i+1)
16387                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16388                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16389                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16390                  vbld(i+nres)
16391                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16392               enddo
16393            else
16394 !   obtaining the derivatives of omega from cosines
16395              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16396              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16397              fac12=fac10*sina
16398              fac13=fac12*fac12
16399              fac14=sina*sina
16400              do j=1,3
16401                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16402                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16403                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16404                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16405                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
16406                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
16407                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
16408                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
16409                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
16410                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
16411                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
16412                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
16413                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
16414                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
16415                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
16416             enddo
16417           endif
16418          else
16419            do j=1,3
16420              do k=1,3
16421                dalpha(k,j,i)=0.0d0
16422                domega(k,j,i)=0.0d0
16423              enddo
16424            enddo
16425          endif
16426        enddo
16427 #endif
16428 #if defined(MPI) && defined(PARINTDER)
16429       if (nfgtasks.gt.1) then
16430 #ifdef DEBUG
16431 !d      write (iout,*) "Gather dtheta"
16432 !d      call flush(iout)
16433       write (iout,*) "dtheta before gather"
16434       do i=1,nres
16435         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
16436       enddo
16437 #endif
16438       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
16439         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
16440         king,FG_COMM,IERROR)
16441 #ifdef DEBUG
16442 !d      write (iout,*) "Gather dphi"
16443 !d      call flush(iout)
16444       write (iout,*) "dphi before gather"
16445       do i=1,nres
16446         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
16447       enddo
16448 #endif
16449       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
16450         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
16451         king,FG_COMM,IERROR)
16452 !d      write (iout,*) "Gather dalpha"
16453 !d      call flush(iout)
16454 #ifdef CRYST_SC
16455       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
16456         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16457         king,FG_COMM,IERROR)
16458 !d      write (iout,*) "Gather domega"
16459 !d      call flush(iout)
16460       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
16461         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16462         king,FG_COMM,IERROR)
16463 #endif
16464       endif
16465 #endif
16466 #ifdef DEBUG
16467       write (iout,*) "dtheta after gather"
16468       do i=1,nres
16469         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
16470       enddo
16471       write (iout,*) "dphi after gather"
16472       do i=1,nres
16473         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
16474       enddo
16475       write (iout,*) "dalpha after gather"
16476       do i=1,nres
16477         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
16478       enddo
16479       write (iout,*) "domega after gather"
16480       do i=1,nres
16481         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
16482       enddo
16483 #endif
16484       return
16485       end subroutine intcartderiv
16486 !-----------------------------------------------------------------------------
16487       subroutine checkintcartgrad
16488 !      implicit real*8 (a-h,o-z)
16489 !      include 'DIMENSIONS'
16490 #ifdef MPI
16491       include 'mpif.h'
16492 #endif
16493 !      include 'COMMON.CHAIN'
16494 !      include 'COMMON.VAR'
16495 !      include 'COMMON.GEO'
16496 !      include 'COMMON.INTERACT'
16497 !      include 'COMMON.DERIV'
16498 !      include 'COMMON.IOUNITS'
16499 !      include 'COMMON.SETUP'
16500       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
16501       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
16502       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
16503       real(kind=8),dimension(3) :: dc_norm_s
16504       real(kind=8) :: aincr=1.0d-5
16505       integer :: i,j
16506       real(kind=8) :: dcji
16507       do i=1,nres
16508         phi_s(i)=phi(i)
16509         theta_s(i)=theta(i)
16510         alph_s(i)=alph(i)
16511         omeg_s(i)=omeg(i)
16512       enddo
16513 ! Check theta gradient
16514       write (iout,*) &
16515        "Analytical (upper) and numerical (lower) gradient of theta"
16516       write (iout,*)
16517       do i=3,nres
16518         do j=1,3
16519           dcji=dc(j,i-2)
16520           dc(j,i-2)=dcji+aincr
16521           call chainbuild_cart
16522           call int_from_cart1(.false.)
16523           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
16524           dc(j,i-2)=dcji
16525           dcji=dc(j,i-1)
16526           dc(j,i-1)=dc(j,i-1)+aincr
16527           call chainbuild_cart
16528           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
16529           dc(j,i-1)=dcji
16530         enddo
16531 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
16532 !el          (dtheta(j,2,i),j=1,3)
16533 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
16534 !el          (dthetanum(j,2,i),j=1,3)
16535 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
16536 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
16537 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
16538 !el        write (iout,*)
16539       enddo
16540 ! Check gamma gradient
16541       write (iout,*) &
16542        "Analytical (upper) and numerical (lower) gradient of gamma"
16543       do i=4,nres
16544         do j=1,3
16545           dcji=dc(j,i-3)
16546           dc(j,i-3)=dcji+aincr
16547           call chainbuild_cart
16548           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
16549           dc(j,i-3)=dcji
16550           dcji=dc(j,i-2)
16551           dc(j,i-2)=dcji+aincr
16552           call chainbuild_cart
16553           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
16554           dc(j,i-2)=dcji
16555           dcji=dc(j,i-1)
16556           dc(j,i-1)=dc(j,i-1)+aincr
16557           call chainbuild_cart
16558           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
16559           dc(j,i-1)=dcji
16560         enddo
16561 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
16562 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
16563 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
16564 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
16565 !el        write (iout,'(5x,3(3f10.5,5x))') &
16566 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
16567 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
16568 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
16569 !el        write (iout,*)
16570       enddo
16571 ! Check alpha gradient
16572       write (iout,*) &
16573        "Analytical (upper) and numerical (lower) gradient of alpha"
16574       do i=2,nres-1
16575        if(itype(i).ne.10) then
16576             do j=1,3
16577               dcji=dc(j,i-1)
16578               dc(j,i-1)=dcji+aincr
16579               call chainbuild_cart
16580               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
16581               /aincr
16582               dc(j,i-1)=dcji
16583               dcji=dc(j,i)
16584               dc(j,i)=dcji+aincr
16585               call chainbuild_cart
16586               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
16587               /aincr
16588               dc(j,i)=dcji
16589               dcji=dc(j,i+nres)
16590               dc(j,i+nres)=dc(j,i+nres)+aincr
16591               call chainbuild_cart
16592               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
16593               /aincr
16594              dc(j,i+nres)=dcji
16595             enddo
16596           endif
16597 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
16598 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
16599 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
16600 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
16601 !el        write (iout,'(5x,3(3f10.5,5x))') &
16602 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
16603 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
16604 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
16605 !el        write (iout,*)
16606       enddo
16607 !     Check omega gradient
16608       write (iout,*) &
16609        "Analytical (upper) and numerical (lower) gradient of omega"
16610       do i=2,nres-1
16611        if(itype(i).ne.10) then
16612             do j=1,3
16613               dcji=dc(j,i-1)
16614               dc(j,i-1)=dcji+aincr
16615               call chainbuild_cart
16616               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
16617               /aincr
16618               dc(j,i-1)=dcji
16619               dcji=dc(j,i)
16620               dc(j,i)=dcji+aincr
16621               call chainbuild_cart
16622               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
16623               /aincr
16624               dc(j,i)=dcji
16625               dcji=dc(j,i+nres)
16626               dc(j,i+nres)=dc(j,i+nres)+aincr
16627               call chainbuild_cart
16628               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
16629               /aincr
16630              dc(j,i+nres)=dcji
16631             enddo
16632           endif
16633 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
16634 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
16635 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
16636 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
16637 !el        write (iout,'(5x,3(3f10.5,5x))') &
16638 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
16639 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
16640 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
16641 !el        write (iout,*)
16642       enddo
16643       return
16644       end subroutine checkintcartgrad
16645 !-----------------------------------------------------------------------------
16646 ! q_measure.F
16647 !-----------------------------------------------------------------------------
16648       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
16649 !      implicit real*8 (a-h,o-z)
16650 !      include 'DIMENSIONS'
16651 !      include 'COMMON.IOUNITS'
16652 !      include 'COMMON.CHAIN'
16653 !      include 'COMMON.INTERACT'
16654 !      include 'COMMON.VAR'
16655       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
16656       integer :: kkk,nsep=3
16657       real(kind=8) :: qm        !dist,
16658       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
16659       logical :: lprn=.false.
16660       logical :: flag
16661 !      real(kind=8) :: sigm,x
16662
16663 !el      sigm(x)=0.25d0*x     ! local function
16664       qqmax=1.0d10
16665       do kkk=1,nperm
16666       qq = 0.0d0
16667       nl=0
16668        if(flag) then
16669         do il=seg1+nsep,seg2
16670           do jl=seg1,il-nsep
16671             nl=nl+1
16672             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
16673                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
16674                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16675             dij=dist(il,jl)
16676             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
16677             if (itype(il).ne.10 .or. itype(jl).ne.10) then
16678               nl=nl+1
16679               d0ijCM=dsqrt( &
16680                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16681                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16682                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16683               dijCM=dist(il+nres,jl+nres)
16684               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
16685             endif
16686             qq = qq+qqij+qqijCM
16687           enddo
16688         enddo
16689         qq = qq/nl
16690       else
16691       do il=seg1,seg2
16692         if((seg3-il).lt.3) then
16693              secseg=il+3
16694         else
16695              secseg=seg3
16696         endif
16697           do jl=secseg,seg4
16698             nl=nl+1
16699             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16700                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16701                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16702             dij=dist(il,jl)
16703             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
16704             if (itype(il).ne.10 .or. itype(jl).ne.10) then
16705               nl=nl+1
16706               d0ijCM=dsqrt( &
16707                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16708                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16709                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16710               dijCM=dist(il+nres,jl+nres)
16711               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
16712             endif
16713             qq = qq+qqij+qqijCM
16714           enddo
16715         enddo
16716       qq = qq/nl
16717       endif
16718       if (qqmax.le.qq) qqmax=qq
16719       enddo
16720       qwolynes=1.0d0-qqmax
16721       return
16722       end function qwolynes
16723 !-----------------------------------------------------------------------------
16724       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
16725 !      implicit real*8 (a-h,o-z)
16726 !      include 'DIMENSIONS'
16727 !      include 'COMMON.IOUNITS'
16728 !      include 'COMMON.CHAIN'
16729 !      include 'COMMON.INTERACT'
16730 !      include 'COMMON.VAR'
16731 !      include 'COMMON.MD'
16732       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
16733       integer :: nsep=3, kkk
16734 !el      real(kind=8) :: dist
16735       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
16736       logical :: lprn=.false.
16737       logical :: flag
16738       real(kind=8) :: sim,dd0,fac,ddqij
16739 !el      sigm(x)=0.25d0*x            ! local function
16740       do kkk=1,nperm
16741       do i=0,nres
16742         do j=1,3
16743           dqwol(j,i)=0.0d0
16744           dxqwol(j,i)=0.0d0
16745         enddo
16746       enddo
16747       nl=0
16748        if(flag) then
16749         do il=seg1+nsep,seg2
16750           do jl=seg1,il-nsep
16751             nl=nl+1
16752             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16753                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16754                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16755             dij=dist(il,jl)
16756             sim = 1.0d0/sigm(d0ij)
16757             sim = sim*sim
16758             dd0 = dij-d0ij
16759             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
16760             do k=1,3
16761               ddqij = (c(k,il)-c(k,jl))*fac
16762               dqwol(k,il)=dqwol(k,il)+ddqij
16763               dqwol(k,jl)=dqwol(k,jl)-ddqij
16764             enddo
16765
16766             if (itype(il).ne.10 .or. itype(jl).ne.10) then
16767               nl=nl+1
16768               d0ijCM=dsqrt( &
16769                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16770                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16771                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16772               dijCM=dist(il+nres,jl+nres)
16773               sim = 1.0d0/sigm(d0ijCM)
16774               sim = sim*sim
16775               dd0=dijCM-d0ijCM
16776               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
16777               do k=1,3
16778                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
16779                 dxqwol(k,il)=dxqwol(k,il)+ddqij
16780                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
16781               enddo
16782             endif
16783           enddo
16784         enddo
16785        else
16786         do il=seg1,seg2
16787         if((seg3-il).lt.3) then
16788              secseg=il+3
16789         else
16790              secseg=seg3
16791         endif
16792           do jl=secseg,seg4
16793             nl=nl+1
16794             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16795                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16796                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16797             dij=dist(il,jl)
16798             sim = 1.0d0/sigm(d0ij)
16799             sim = sim*sim
16800             dd0 = dij-d0ij
16801             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
16802             do k=1,3
16803               ddqij = (c(k,il)-c(k,jl))*fac
16804               dqwol(k,il)=dqwol(k,il)+ddqij
16805               dqwol(k,jl)=dqwol(k,jl)-ddqij
16806             enddo
16807             if (itype(il).ne.10 .or. itype(jl).ne.10) then
16808               nl=nl+1
16809               d0ijCM=dsqrt( &
16810                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16811                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16812                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16813               dijCM=dist(il+nres,jl+nres)
16814               sim = 1.0d0/sigm(d0ijCM)
16815               sim=sim*sim
16816               dd0 = dijCM-d0ijCM
16817               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
16818               do k=1,3
16819                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
16820                dxqwol(k,il)=dxqwol(k,il)+ddqij
16821                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
16822               enddo
16823             endif
16824           enddo
16825         enddo
16826       endif
16827       enddo
16828        do i=0,nres
16829          do j=1,3
16830            dqwol(j,i)=dqwol(j,i)/nl
16831            dxqwol(j,i)=dxqwol(j,i)/nl
16832          enddo
16833        enddo
16834       return
16835       end subroutine qwolynes_prim
16836 !-----------------------------------------------------------------------------
16837       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
16838 !      implicit real*8 (a-h,o-z)
16839 !      include 'DIMENSIONS'
16840 !      include 'COMMON.IOUNITS'
16841 !      include 'COMMON.CHAIN'
16842 !      include 'COMMON.INTERACT'
16843 !      include 'COMMON.VAR'
16844       integer :: seg1,seg2,seg3,seg4
16845       logical :: flag
16846       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
16847       real(kind=8),dimension(3,0:2*nres) :: cdummy
16848       real(kind=8) :: q1,q2
16849       real(kind=8) :: delta=1.0d-10
16850       integer :: i,j
16851
16852       do i=0,nres
16853         do j=1,3
16854           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
16855           cdummy(j,i)=c(j,i)
16856           c(j,i)=c(j,i)+delta
16857           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
16858           qwolan(j,i)=(q2-q1)/delta
16859           c(j,i)=cdummy(j,i)
16860         enddo
16861       enddo
16862       do i=0,nres
16863         do j=1,3
16864           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
16865           cdummy(j,i+nres)=c(j,i+nres)
16866           c(j,i+nres)=c(j,i+nres)+delta
16867           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
16868           qwolxan(j,i)=(q2-q1)/delta
16869           c(j,i+nres)=cdummy(j,i+nres)
16870         enddo
16871       enddo
16872 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
16873 !      do i=0,nct
16874 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
16875 !      enddo
16876 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
16877 !      do i=0,nct
16878 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
16879 !      enddo
16880       return
16881       end subroutine qwol_num
16882 !-----------------------------------------------------------------------------
16883       subroutine EconstrQ
16884 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
16885 !      implicit real*8 (a-h,o-z)
16886 !      include 'DIMENSIONS'
16887 !      include 'COMMON.CONTROL'
16888 !      include 'COMMON.VAR'
16889 !      include 'COMMON.MD'
16890       use MD_data
16891 !#ifndef LANG0
16892 !      include 'COMMON.LANGEVIN'
16893 !#else
16894 !      include 'COMMON.LANGEVIN.lang0'
16895 !#endif
16896 !      include 'COMMON.CHAIN'
16897 !      include 'COMMON.DERIV'
16898 !      include 'COMMON.GEO'
16899 !      include 'COMMON.LOCAL'
16900 !      include 'COMMON.INTERACT'
16901 !      include 'COMMON.IOUNITS'
16902 !      include 'COMMON.NAMES'
16903 !      include 'COMMON.TIME1'
16904       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
16905       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
16906                    duconst,duxconst
16907       integer :: kstart,kend,lstart,lend,idummy
16908       real(kind=8) :: delta=1.0d-7
16909       integer :: i,j,k,ii
16910       do i=0,nres
16911          do j=1,3
16912             duconst(j,i)=0.0d0
16913             dudconst(j,i)=0.0d0
16914             duxconst(j,i)=0.0d0
16915             dudxconst(j,i)=0.0d0
16916          enddo
16917       enddo
16918       Uconst=0.0d0
16919       do i=1,nfrag
16920          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
16921            idummy,idummy)
16922          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
16923 ! Calculating the derivatives of Constraint energy with respect to Q
16924          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
16925            qinfrag(i,iset))
16926 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
16927 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
16928 !         hmnum=(hm2-hm1)/delta
16929 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
16930 !     &   qinfrag(i,iset))
16931 !         write(iout,*) "harmonicnum frag", hmnum
16932 ! Calculating the derivatives of Q with respect to cartesian coordinates
16933          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
16934           idummy,idummy)
16935 !         write(iout,*) "dqwol "
16936 !         do ii=1,nres
16937 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
16938 !         enddo
16939 !         write(iout,*) "dxqwol "
16940 !         do ii=1,nres
16941 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
16942 !         enddo
16943 ! Calculating numerical gradients of dU/dQi and dQi/dxi
16944 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
16945 !     &  ,idummy,idummy)
16946 !  The gradients of Uconst in Cs
16947          do ii=0,nres
16948             do j=1,3
16949                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
16950                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
16951             enddo
16952          enddo
16953       enddo
16954       do i=1,npair
16955          kstart=ifrag(1,ipair(1,i,iset),iset)
16956          kend=ifrag(2,ipair(1,i,iset),iset)
16957          lstart=ifrag(1,ipair(2,i,iset),iset)
16958          lend=ifrag(2,ipair(2,i,iset),iset)
16959          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
16960          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
16961 !  Calculating dU/dQ
16962          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
16963 !         hm1=harmonic(qpair(i),qinpair(i,iset))
16964 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
16965 !         hmnum=(hm2-hm1)/delta
16966 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
16967 !     &   qinpair(i,iset))
16968 !         write(iout,*) "harmonicnum pair ", hmnum
16969 ! Calculating dQ/dXi
16970          call qwolynes_prim(kstart,kend,.false.,&
16971           lstart,lend)
16972 !         write(iout,*) "dqwol "
16973 !         do ii=1,nres
16974 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
16975 !         enddo
16976 !         write(iout,*) "dxqwol "
16977 !         do ii=1,nres
16978 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
16979 !        enddo
16980 ! Calculating numerical gradients
16981 !        call qwol_num(kstart,kend,.false.
16982 !     &  ,lstart,lend)
16983 ! The gradients of Uconst in Cs
16984          do ii=0,nres
16985             do j=1,3
16986                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
16987                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
16988             enddo
16989          enddo
16990       enddo
16991 !      write(iout,*) "Uconst inside subroutine ", Uconst
16992 ! Transforming the gradients from Cs to dCs for the backbone
16993       do i=0,nres
16994          do j=i+1,nres
16995            do k=1,3
16996              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
16997            enddo
16998          enddo
16999       enddo
17000 !  Transforming the gradients from Cs to dCs for the side chains
17001       do i=1,nres
17002          do j=1,3
17003            dudxconst(j,i)=duxconst(j,i)
17004          enddo
17005       enddo
17006 !      write(iout,*) "dU/ddc backbone "
17007 !       do ii=0,nres
17008 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17009 !      enddo
17010 !      write(iout,*) "dU/ddX side chain "
17011 !      do ii=1,nres
17012 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17013 !      enddo
17014 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17015 !      call dEconstrQ_num
17016       return
17017       end subroutine EconstrQ
17018 !-----------------------------------------------------------------------------
17019       subroutine dEconstrQ_num
17020 ! Calculating numerical dUconst/ddc and dUconst/ddx
17021 !      implicit real*8 (a-h,o-z)
17022 !      include 'DIMENSIONS'
17023 !      include 'COMMON.CONTROL'
17024 !      include 'COMMON.VAR'
17025 !      include 'COMMON.MD'
17026       use MD_data
17027 !#ifndef LANG0
17028 !      include 'COMMON.LANGEVIN'
17029 !#else
17030 !      include 'COMMON.LANGEVIN.lang0'
17031 !#endif
17032 !      include 'COMMON.CHAIN'
17033 !      include 'COMMON.DERIV'
17034 !      include 'COMMON.GEO'
17035 !      include 'COMMON.LOCAL'
17036 !      include 'COMMON.INTERACT'
17037 !      include 'COMMON.IOUNITS'
17038 !      include 'COMMON.NAMES'
17039 !      include 'COMMON.TIME1'
17040       real(kind=8) :: uzap1,uzap2
17041       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17042       integer :: kstart,kend,lstart,lend,idummy
17043       real(kind=8) :: delta=1.0d-7
17044 !el local variables
17045       integer :: i,ii,j
17046 !     real(kind=8) ::
17047 !     For the backbone
17048       do i=0,nres-1
17049          do j=1,3
17050             dUcartan(j,i)=0.0d0
17051             cdummy(j,i)=dc(j,i)
17052             dc(j,i)=dc(j,i)+delta
17053             call chainbuild_cart
17054             uzap2=0.0d0
17055             do ii=1,nfrag
17056              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17057                 idummy,idummy)
17058                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17059                 qinfrag(ii,iset))
17060             enddo
17061             do ii=1,npair
17062                kstart=ifrag(1,ipair(1,ii,iset),iset)
17063                kend=ifrag(2,ipair(1,ii,iset),iset)
17064                lstart=ifrag(1,ipair(2,ii,iset),iset)
17065                lend=ifrag(2,ipair(2,ii,iset),iset)
17066                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17067                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17068                  qinpair(ii,iset))
17069             enddo
17070             dc(j,i)=cdummy(j,i)
17071             call chainbuild_cart
17072             uzap1=0.0d0
17073              do ii=1,nfrag
17074              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17075                 idummy,idummy)
17076                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17077                 qinfrag(ii,iset))
17078             enddo
17079             do ii=1,npair
17080                kstart=ifrag(1,ipair(1,ii,iset),iset)
17081                kend=ifrag(2,ipair(1,ii,iset),iset)
17082                lstart=ifrag(1,ipair(2,ii,iset),iset)
17083                lend=ifrag(2,ipair(2,ii,iset),iset)
17084                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17085                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17086                 qinpair(ii,iset))
17087             enddo
17088             ducartan(j,i)=(uzap2-uzap1)/(delta)
17089          enddo
17090       enddo
17091 ! Calculating numerical gradients for dU/ddx
17092       do i=0,nres-1
17093          duxcartan(j,i)=0.0d0
17094          do j=1,3
17095             cdummy(j,i)=dc(j,i+nres)
17096             dc(j,i+nres)=dc(j,i+nres)+delta
17097             call chainbuild_cart
17098             uzap2=0.0d0
17099             do ii=1,nfrag
17100              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17101                 idummy,idummy)
17102                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17103                 qinfrag(ii,iset))
17104             enddo
17105             do ii=1,npair
17106                kstart=ifrag(1,ipair(1,ii,iset),iset)
17107                kend=ifrag(2,ipair(1,ii,iset),iset)
17108                lstart=ifrag(1,ipair(2,ii,iset),iset)
17109                lend=ifrag(2,ipair(2,ii,iset),iset)
17110                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17111                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17112                 qinpair(ii,iset))
17113             enddo
17114             dc(j,i+nres)=cdummy(j,i)
17115             call chainbuild_cart
17116             uzap1=0.0d0
17117              do ii=1,nfrag
17118                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17119                 ifrag(2,ii,iset),.true.,idummy,idummy)
17120                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17121                 qinfrag(ii,iset))
17122             enddo
17123             do ii=1,npair
17124                kstart=ifrag(1,ipair(1,ii,iset),iset)
17125                kend=ifrag(2,ipair(1,ii,iset),iset)
17126                lstart=ifrag(1,ipair(2,ii,iset),iset)
17127                lend=ifrag(2,ipair(2,ii,iset),iset)
17128                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17129                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17130                 qinpair(ii,iset))
17131             enddo
17132             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17133          enddo
17134       enddo
17135       write(iout,*) "Numerical dUconst/ddc backbone "
17136       do ii=0,nres
17137         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17138       enddo
17139 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17140 !      do ii=1,nres
17141 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17142 !      enddo
17143       return
17144       end subroutine dEconstrQ_num
17145 !-----------------------------------------------------------------------------
17146 ! ssMD.F
17147 !-----------------------------------------------------------------------------
17148       subroutine check_energies
17149
17150 !      use random, only: ran_number
17151
17152 !      implicit none
17153 !     Includes
17154 !      include 'DIMENSIONS'
17155 !      include 'COMMON.CHAIN'
17156 !      include 'COMMON.VAR'
17157 !      include 'COMMON.IOUNITS'
17158 !      include 'COMMON.SBRIDGE'
17159 !      include 'COMMON.LOCAL'
17160 !      include 'COMMON.GEO'
17161
17162 !     External functions
17163 !EL      double precision ran_number
17164 !EL      external ran_number
17165
17166 !     Local variables
17167       integer :: i,j,k,l,lmax,p,pmax
17168       real(kind=8) :: rmin,rmax
17169       real(kind=8) :: eij
17170
17171       real(kind=8) :: d
17172       real(kind=8) :: wi,rij,tj,pj
17173 !      return
17174
17175       i=5
17176       j=14
17177
17178       d=dsc(1)
17179       rmin=2.0D0
17180       rmax=12.0D0
17181
17182       lmax=10000
17183       pmax=1
17184
17185       do k=1,3
17186         c(k,i)=0.0D0
17187         c(k,j)=0.0D0
17188         c(k,nres+i)=0.0D0
17189         c(k,nres+j)=0.0D0
17190       enddo
17191
17192       do l=1,lmax
17193
17194 !t        wi=ran_number(0.0D0,pi)
17195 !        wi=ran_number(0.0D0,pi/6.0D0)
17196 !        wi=0.0D0
17197 !t        tj=ran_number(0.0D0,pi)
17198 !t        pj=ran_number(0.0D0,pi)
17199 !        pj=ran_number(0.0D0,pi/6.0D0)
17200 !        pj=0.0D0
17201
17202         do p=1,pmax
17203 !t           rij=ran_number(rmin,rmax)
17204
17205            c(1,j)=d*sin(pj)*cos(tj)
17206            c(2,j)=d*sin(pj)*sin(tj)
17207            c(3,j)=d*cos(pj)
17208
17209            c(3,nres+i)=-rij
17210
17211            c(1,i)=d*sin(wi)
17212            c(3,i)=-rij-d*cos(wi)
17213
17214            do k=1,3
17215               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17216               dc_norm(k,nres+i)=dc(k,nres+i)/d
17217               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17218               dc_norm(k,nres+j)=dc(k,nres+j)/d
17219            enddo
17220
17221            call dyn_ssbond_ene(i,j,eij)
17222         enddo
17223       enddo
17224       call exit(1)
17225       return
17226       end subroutine check_energies
17227 !-----------------------------------------------------------------------------
17228       subroutine dyn_ssbond_ene(resi,resj,eij)
17229 !      implicit none
17230 !      Includes
17231       use calc_data
17232       use comm_sschecks
17233 !      include 'DIMENSIONS'
17234 !      include 'COMMON.SBRIDGE'
17235 !      include 'COMMON.CHAIN'
17236 !      include 'COMMON.DERIV'
17237 !      include 'COMMON.LOCAL'
17238 !      include 'COMMON.INTERACT'
17239 !      include 'COMMON.VAR'
17240 !      include 'COMMON.IOUNITS'
17241 !      include 'COMMON.CALC'
17242 #ifndef CLUST
17243 #ifndef WHAM
17244        use MD_data
17245 !      include 'COMMON.MD'
17246 !      use MD, only: totT,t_bath
17247 #endif
17248 #endif
17249 !     External functions
17250 !EL      double precision h_base
17251 !EL      external h_base
17252
17253 !     Input arguments
17254       integer :: resi,resj
17255
17256 !     Output arguments
17257       real(kind=8) :: eij
17258
17259 !     Local variables
17260       logical :: havebond
17261       integer itypi,itypj
17262       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17263       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17264       real(kind=8),dimension(3) :: dcosom1,dcosom2
17265       real(kind=8) :: ed
17266       real(kind=8) :: pom1,pom2
17267       real(kind=8) :: ljA,ljB,ljXs
17268       real(kind=8),dimension(1:3) :: d_ljB
17269       real(kind=8) :: ssA,ssB,ssC,ssXs
17270       real(kind=8) :: ssxm,ljxm,ssm,ljm
17271       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17272       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17273       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17274 !-------FIRST METHOD
17275       real(kind=8) :: xm
17276       real(kind=8),dimension(1:3) :: d_xm
17277 !-------END FIRST METHOD
17278 !-------SECOND METHOD
17279 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17280 !-------END SECOND METHOD
17281
17282 !-------TESTING CODE
17283 !el      logical :: checkstop,transgrad
17284 !el      common /sschecks/ checkstop,transgrad
17285
17286       integer :: icheck,nicheck,jcheck,njcheck
17287       real(kind=8),dimension(-1:1) :: echeck
17288       real(kind=8) :: deps,ssx0,ljx0
17289 !-------END TESTING CODE
17290
17291       eij=0.0d0
17292       i=resi
17293       j=resj
17294
17295 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17296 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17297
17298       itypi=itype(i)
17299       dxi=dc_norm(1,nres+i)
17300       dyi=dc_norm(2,nres+i)
17301       dzi=dc_norm(3,nres+i)
17302       dsci_inv=vbld_inv(i+nres)
17303
17304       itypj=itype(j)
17305       xj=c(1,nres+j)-c(1,nres+i)
17306       yj=c(2,nres+j)-c(2,nres+i)
17307       zj=c(3,nres+j)-c(3,nres+i)
17308       dxj=dc_norm(1,nres+j)
17309       dyj=dc_norm(2,nres+j)
17310       dzj=dc_norm(3,nres+j)
17311       dscj_inv=vbld_inv(j+nres)
17312
17313       chi1=chi(itypi,itypj)
17314       chi2=chi(itypj,itypi)
17315       chi12=chi1*chi2
17316       chip1=chip(itypi)
17317       chip2=chip(itypj)
17318       chip12=chip1*chip2
17319       alf1=alp(itypi)
17320       alf2=alp(itypj)
17321       alf12=0.5D0*(alf1+alf2)
17322
17323       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17324       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17325 !     The following are set in sc_angular
17326 !      erij(1)=xj*rij
17327 !      erij(2)=yj*rij
17328 !      erij(3)=zj*rij
17329 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17330 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17331 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17332       call sc_angular
17333       rij=1.0D0/rij  ! Reset this so it makes sense
17334
17335       sig0ij=sigma(itypi,itypj)
17336       sig=sig0ij*dsqrt(1.0D0/sigsq)
17337
17338       ljXs=sig-sig0ij
17339       ljA=eps1*eps2rt**2*eps3rt**2
17340       ljB=ljA*bb_aq(itypi,itypj)
17341       ljA=ljA*aa_aq(itypi,itypj)
17342       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17343
17344       ssXs=d0cm
17345       deltat1=1.0d0-om1
17346       deltat2=1.0d0+om2
17347       deltat12=om2-om1+2.0d0
17348       cosphi=om12-om1*om2
17349       ssA=akcm
17350       ssB=akct*deltat12
17351       ssC=ss_depth &
17352            +akth*(deltat1*deltat1+deltat2*deltat2) &
17353            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17354       ssxm=ssXs-0.5D0*ssB/ssA
17355
17356 !-------TESTING CODE
17357 !$$$c     Some extra output
17358 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17359 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17360 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17361 !$$$      if (ssx0.gt.0.0d0) then
17362 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17363 !$$$      else
17364 !$$$        ssx0=ssxm
17365 !$$$      endif
17366 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17367 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17368 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17369 !$$$      return
17370 !-------END TESTING CODE
17371
17372 !-------TESTING CODE
17373 !     Stop and plot energy and derivative as a function of distance
17374       if (checkstop) then
17375         ssm=ssC-0.25D0*ssB*ssB/ssA
17376         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17377         if (ssm.lt.ljm .and. &
17378              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17379           nicheck=1000
17380           njcheck=1
17381           deps=0.5d-7
17382         else
17383           checkstop=.false.
17384         endif
17385       endif
17386       if (.not.checkstop) then
17387         nicheck=0
17388         njcheck=-1
17389       endif
17390
17391       do icheck=0,nicheck
17392       do jcheck=-1,njcheck
17393       if (checkstop) rij=(ssxm-1.0d0)+ &
17394              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17395 !-------END TESTING CODE
17396
17397       if (rij.gt.ljxm) then
17398         havebond=.false.
17399         ljd=rij-ljXs
17400         fac=(1.0D0/ljd)**expon
17401         e1=fac*fac*aa_aq(itypi,itypj)
17402         e2=fac*bb_aq(itypi,itypj)
17403         eij=eps1*eps2rt*eps3rt*(e1+e2)
17404         eps2der=eij*eps3rt
17405         eps3der=eij*eps2rt
17406         eij=eij*eps2rt*eps3rt
17407
17408         sigder=-sig/sigsq
17409         e1=e1*eps1*eps2rt**2*eps3rt**2
17410         ed=-expon*(e1+eij)/ljd
17411         sigder=ed*sigder
17412         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17413         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17414         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
17415              -2.0D0*alf12*eps3der+sigder*sigsq_om12
17416       else if (rij.lt.ssxm) then
17417         havebond=.true.
17418         ssd=rij-ssXs
17419         eij=ssA*ssd*ssd+ssB*ssd+ssC
17420
17421         ed=2*akcm*ssd+akct*deltat12
17422         pom1=akct*ssd
17423         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
17424         eom1=-2*akth*deltat1-pom1-om2*pom2
17425         eom2= 2*akth*deltat2+pom1-om1*pom2
17426         eom12=pom2
17427       else
17428         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
17429
17430         d_ssxm(1)=0.5D0*akct/ssA
17431         d_ssxm(2)=-d_ssxm(1)
17432         d_ssxm(3)=0.0D0
17433
17434         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
17435         d_ljxm(2)=d_ljxm(1)*sigsq_om2
17436         d_ljxm(3)=d_ljxm(1)*sigsq_om12
17437         d_ljxm(1)=d_ljxm(1)*sigsq_om1
17438
17439 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17440         xm=0.5d0*(ssxm+ljxm)
17441         do k=1,3
17442           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
17443         enddo
17444         if (rij.lt.xm) then
17445           havebond=.true.
17446           ssm=ssC-0.25D0*ssB*ssB/ssA
17447           d_ssm(1)=0.5D0*akct*ssB/ssA
17448           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17449           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17450           d_ssm(3)=omega
17451           f1=(rij-xm)/(ssxm-xm)
17452           f2=(rij-ssxm)/(xm-ssxm)
17453           h1=h_base(f1,hd1)
17454           h2=h_base(f2,hd2)
17455           eij=ssm*h1+Ht*h2
17456           delta_inv=1.0d0/(xm-ssxm)
17457           deltasq_inv=delta_inv*delta_inv
17458           fac=ssm*hd1-Ht*hd2
17459           fac1=deltasq_inv*fac*(xm-rij)
17460           fac2=deltasq_inv*fac*(rij-ssxm)
17461           ed=delta_inv*(Ht*hd2-ssm*hd1)
17462           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
17463           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
17464           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
17465         else
17466           havebond=.false.
17467           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17468           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
17469           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
17470           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
17471                alf12/eps3rt)
17472           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
17473           f1=(rij-ljxm)/(xm-ljxm)
17474           f2=(rij-xm)/(ljxm-xm)
17475           h1=h_base(f1,hd1)
17476           h2=h_base(f2,hd2)
17477           eij=Ht*h1+ljm*h2
17478           delta_inv=1.0d0/(ljxm-xm)
17479           deltasq_inv=delta_inv*delta_inv
17480           fac=Ht*hd1-ljm*hd2
17481           fac1=deltasq_inv*fac*(ljxm-rij)
17482           fac2=deltasq_inv*fac*(rij-xm)
17483           ed=delta_inv*(ljm*hd2-Ht*hd1)
17484           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
17485           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
17486           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
17487         endif
17488 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17489
17490 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17491 !$$$        ssd=rij-ssXs
17492 !$$$        ljd=rij-ljXs
17493 !$$$        fac1=rij-ljxm
17494 !$$$        fac2=rij-ssxm
17495 !$$$
17496 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
17497 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
17498 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
17499 !$$$
17500 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
17501 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
17502 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17503 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17504 !$$$        d_ssm(3)=omega
17505 !$$$
17506 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
17507 !$$$        do k=1,3
17508 !$$$          d_ljm(k)=ljm*d_ljB(k)
17509 !$$$        enddo
17510 !$$$        ljm=ljm*ljB
17511 !$$$
17512 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
17513 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
17514 !$$$        d_ss(2)=akct*ssd
17515 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
17516 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
17517 !$$$        d_ss(3)=omega
17518 !$$$
17519 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
17520 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
17521 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
17522 !$$$        do k=1,3
17523 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
17524 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
17525 !$$$        enddo
17526 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
17527 !$$$
17528 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
17529 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
17530 !$$$        h1=h_base(f1,hd1)
17531 !$$$        h2=h_base(f2,hd2)
17532 !$$$        eij=ss*h1+ljf*h2
17533 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
17534 !$$$        deltasq_inv=delta_inv*delta_inv
17535 !$$$        fac=ljf*hd2-ss*hd1
17536 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
17537 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
17538 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
17539 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
17540 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
17541 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
17542 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
17543 !$$$
17544 !$$$        havebond=.false.
17545 !$$$        if (ed.gt.0.0d0) havebond=.true.
17546 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17547
17548       endif
17549
17550       if (havebond) then
17551 !#ifndef CLUST
17552 !#ifndef WHAM
17553 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
17554 !          write(iout,'(a15,f12.2,f8.1,2i5)')
17555 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
17556 !        endif
17557 !#endif
17558 !#endif
17559         dyn_ssbond_ij(i,j)=eij
17560       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
17561         dyn_ssbond_ij(i,j)=1.0d300
17562 !#ifndef CLUST
17563 !#ifndef WHAM
17564 !        write(iout,'(a15,f12.2,f8.1,2i5)')
17565 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
17566 !#endif
17567 !#endif
17568       endif
17569
17570 !-------TESTING CODE
17571 !el      if (checkstop) then
17572         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
17573              "CHECKSTOP",rij,eij,ed
17574         echeck(jcheck)=eij
17575 !el      endif
17576       enddo
17577       if (checkstop) then
17578         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
17579       endif
17580       enddo
17581       if (checkstop) then
17582         transgrad=.true.
17583         checkstop=.false.
17584       endif
17585 !-------END TESTING CODE
17586
17587       do k=1,3
17588         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
17589         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
17590       enddo
17591       do k=1,3
17592         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
17593       enddo
17594       do k=1,3
17595         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
17596              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
17597              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
17598         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
17599              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
17600              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
17601       enddo
17602 !grad      do k=i,j-1
17603 !grad        do l=1,3
17604 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
17605 !grad        enddo
17606 !grad      enddo
17607
17608       do l=1,3
17609         gvdwc(l,i)=gvdwc(l,i)-gg(l)
17610         gvdwc(l,j)=gvdwc(l,j)+gg(l)
17611       enddo
17612
17613       return
17614       end subroutine dyn_ssbond_ene
17615 !-----------------------------------------------------------------------------
17616       real(kind=8) function h_base(x,deriv)
17617 !     A smooth function going 0->1 in range [0,1]
17618 !     It should NOT be called outside range [0,1], it will not work there.
17619       implicit none
17620
17621 !     Input arguments
17622       real(kind=8) :: x
17623
17624 !     Output arguments
17625       real(kind=8) :: deriv
17626
17627 !     Local variables
17628       real(kind=8) :: xsq
17629
17630
17631 !     Two parabolas put together.  First derivative zero at extrema
17632 !$$$      if (x.lt.0.5D0) then
17633 !$$$        h_base=2.0D0*x*x
17634 !$$$        deriv=4.0D0*x
17635 !$$$      else
17636 !$$$        deriv=1.0D0-x
17637 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
17638 !$$$        deriv=4.0D0*deriv
17639 !$$$      endif
17640
17641 !     Third degree polynomial.  First derivative zero at extrema
17642       h_base=x*x*(3.0d0-2.0d0*x)
17643       deriv=6.0d0*x*(1.0d0-x)
17644
17645 !     Fifth degree polynomial.  First and second derivatives zero at extrema
17646 !$$$      xsq=x*x
17647 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
17648 !$$$      deriv=x-1.0d0
17649 !$$$      deriv=deriv*deriv
17650 !$$$      deriv=30.0d0*xsq*deriv
17651
17652       return
17653       end function h_base
17654 !-----------------------------------------------------------------------------
17655       subroutine dyn_set_nss
17656 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
17657 !      implicit none
17658       use MD_data, only: totT,t_bath
17659 !     Includes
17660 !      include 'DIMENSIONS'
17661 #ifdef MPI
17662       include "mpif.h"
17663 #endif
17664 !      include 'COMMON.SBRIDGE'
17665 !      include 'COMMON.CHAIN'
17666 !      include 'COMMON.IOUNITS'
17667 !      include 'COMMON.SETUP'
17668 !      include 'COMMON.MD'
17669 !     Local variables
17670       real(kind=8) :: emin
17671       integer :: i,j,imin,ierr
17672       integer :: diff,allnss,newnss
17673       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
17674                 newihpb,newjhpb
17675       logical :: found
17676       integer,dimension(0:nfgtasks) :: i_newnss
17677       integer,dimension(0:nfgtasks) :: displ
17678       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
17679       integer :: g_newnss
17680
17681       allnss=0
17682       do i=1,nres-1
17683         do j=i+1,nres
17684           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
17685             allnss=allnss+1
17686             allflag(allnss)=0
17687             allihpb(allnss)=i
17688             alljhpb(allnss)=j
17689           endif
17690         enddo
17691       enddo
17692
17693 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
17694
17695  1    emin=1.0d300
17696       do i=1,allnss
17697         if (allflag(i).eq.0 .and. &
17698              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
17699           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
17700           imin=i
17701         endif
17702       enddo
17703       if (emin.lt.1.0d300) then
17704         allflag(imin)=1
17705         do i=1,allnss
17706           if (allflag(i).eq.0 .and. &
17707                (allihpb(i).eq.allihpb(imin) .or. &
17708                alljhpb(i).eq.allihpb(imin) .or. &
17709                allihpb(i).eq.alljhpb(imin) .or. &
17710                alljhpb(i).eq.alljhpb(imin))) then
17711             allflag(i)=-1
17712           endif
17713         enddo
17714         goto 1
17715       endif
17716
17717 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
17718
17719       newnss=0
17720       do i=1,allnss
17721         if (allflag(i).eq.1) then
17722           newnss=newnss+1
17723           newihpb(newnss)=allihpb(i)
17724           newjhpb(newnss)=alljhpb(i)
17725         endif
17726       enddo
17727
17728 #ifdef MPI
17729       if (nfgtasks.gt.1)then
17730
17731         call MPI_Reduce(newnss,g_newnss,1,&
17732           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
17733         call MPI_Gather(newnss,1,MPI_INTEGER,&
17734                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
17735         displ(0)=0
17736         do i=1,nfgtasks-1,1
17737           displ(i)=i_newnss(i-1)+displ(i-1)
17738         enddo
17739         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
17740                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
17741                          king,FG_COMM,IERR)
17742         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
17743                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
17744                          king,FG_COMM,IERR)
17745         if(fg_rank.eq.0) then
17746 !         print *,'g_newnss',g_newnss
17747 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
17748 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
17749          newnss=g_newnss
17750          do i=1,newnss
17751           newihpb(i)=g_newihpb(i)
17752           newjhpb(i)=g_newjhpb(i)
17753          enddo
17754         endif
17755       endif
17756 #endif
17757
17758       diff=newnss-nss
17759
17760 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
17761
17762       do i=1,nss
17763         found=.false.
17764         do j=1,newnss
17765           if (idssb(i).eq.newihpb(j) .and. &
17766                jdssb(i).eq.newjhpb(j)) found=.true.
17767         enddo
17768 #ifndef CLUST
17769 #ifndef WHAM
17770         if (.not.found.and.fg_rank.eq.0) &
17771             write(iout,'(a15,f12.2,f8.1,2i5)') &
17772              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
17773 #endif
17774 #endif
17775       enddo
17776
17777       do i=1,newnss
17778         found=.false.
17779         do j=1,nss
17780           if (newihpb(i).eq.idssb(j) .and. &
17781                newjhpb(i).eq.jdssb(j)) found=.true.
17782         enddo
17783 #ifndef CLUST
17784 #ifndef WHAM
17785         if (.not.found.and.fg_rank.eq.0) &
17786             write(iout,'(a15,f12.2,f8.1,2i5)') &
17787              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
17788 #endif
17789 #endif
17790       enddo
17791
17792       nss=newnss
17793       do i=1,nss
17794         idssb(i)=newihpb(i)
17795         jdssb(i)=newjhpb(i)
17796       enddo
17797
17798       return
17799       end subroutine dyn_set_nss
17800 ! Lipid transfer energy function
17801       subroutine Eliptransfer(eliptran)
17802 !C this is done by Adasko
17803 !C      print *,"wchodze"
17804 !C structure of box:
17805 !C      water
17806 !C--bordliptop-- buffore starts
17807 !C--bufliptop--- here true lipid starts
17808 !C      lipid
17809 !C--buflipbot--- lipid ends buffore starts
17810 !C--bordlipbot--buffore ends
17811       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
17812       integer :: i
17813       eliptran=0.0
17814       print *, "I am in eliptran"
17815       do i=ilip_start,ilip_end
17816 !C       do i=1,1
17817         if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1).or.(i.eq.nres))&
17818          cycle
17819
17820         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
17821         if (positi.le.0.0) positi=positi+boxzsize
17822 !C        print *,i
17823 !C first for peptide groups
17824 !c for each residue check if it is in lipid or lipid water border area
17825        if ((positi.gt.bordlipbot)  &
17826       .and.(positi.lt.bordliptop)) then
17827 !C the energy transfer exist
17828         if (positi.lt.buflipbot) then
17829 !C what fraction I am in
17830          fracinbuf=1.0d0-      &
17831              ((positi-bordlipbot)/lipbufthick)
17832 !C lipbufthick is thickenes of lipid buffore
17833          sslip=sscalelip(fracinbuf)
17834          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
17835          eliptran=eliptran+sslip*pepliptran
17836          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
17837          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
17838 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
17839
17840 !C        print *,"doing sccale for lower part"
17841 !C         print *,i,sslip,fracinbuf,ssgradlip
17842         elseif (positi.gt.bufliptop) then
17843          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
17844          sslip=sscalelip(fracinbuf)
17845          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
17846          eliptran=eliptran+sslip*pepliptran
17847          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
17848          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
17849 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
17850 !C          print *, "doing sscalefor top part"
17851 !C         print *,i,sslip,fracinbuf,ssgradlip
17852         else
17853          eliptran=eliptran+pepliptran
17854 !C         print *,"I am in true lipid"
17855         endif
17856 !C       else
17857 !C       eliptran=elpitran+0.0 ! I am in water
17858        endif
17859        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
17860        enddo
17861 ! here starts the side chain transfer
17862        do i=ilip_start,ilip_end
17863         if (itype(i).eq.ntyp1) cycle
17864         positi=(mod(c(3,i+nres),boxzsize))
17865         if (positi.le.0) positi=positi+boxzsize
17866 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
17867 !c for each residue check if it is in lipid or lipid water border area
17868 !C       respos=mod(c(3,i+nres),boxzsize)
17869 !C       print *,positi,bordlipbot,buflipbot
17870        if ((positi.gt.bordlipbot) &
17871        .and.(positi.lt.bordliptop)) then
17872 !C the energy transfer exist
17873         if (positi.lt.buflipbot) then
17874          fracinbuf=1.0d0-   &
17875            ((positi-bordlipbot)/lipbufthick)
17876 !C lipbufthick is thickenes of lipid buffore
17877          sslip=sscalelip(fracinbuf)
17878          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
17879          eliptran=eliptran+sslip*liptranene(itype(i))
17880          gliptranx(3,i)=gliptranx(3,i) &
17881       +ssgradlip*liptranene(itype(i))
17882          gliptranc(3,i-1)= gliptranc(3,i-1) &
17883       +ssgradlip*liptranene(itype(i))
17884 !C         print *,"doing sccale for lower part"
17885         elseif (positi.gt.bufliptop) then
17886          fracinbuf=1.0d0-  &
17887       ((bordliptop-positi)/lipbufthick)
17888          sslip=sscalelip(fracinbuf)
17889          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
17890          eliptran=eliptran+sslip*liptranene(itype(i))
17891          gliptranx(3,i)=gliptranx(3,i)  &
17892        +ssgradlip*liptranene(itype(i))
17893          gliptranc(3,i-1)= gliptranc(3,i-1) &
17894       +ssgradlip*liptranene(itype(i))
17895 !C          print *, "doing sscalefor top part",sslip,fracinbuf
17896         else
17897          eliptran=eliptran+liptranene(itype(i))
17898 !C         print *,"I am in true lipid"
17899         endif
17900         endif ! if in lipid or buffor
17901 !C       else
17902 !C       eliptran=elpitran+0.0 ! I am in water
17903         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
17904        enddo
17905        return
17906        end  subroutine Eliptransfer
17907 !--------------------------------------------------------------------------------
17908 !C first for shielding is setting of function of side-chains
17909
17910        subroutine set_shield_fac2
17911        real(kind=8) :: div77_81=0.974996043d0, &
17912         div4_81=0.2222222222d0
17913        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
17914          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
17915          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
17916          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
17917 !C the vector between center of side_chain and peptide group
17918        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
17919          pept_group,costhet_grad,cosphi_grad_long, &
17920          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
17921          sh_frac_dist_grad,pep_side
17922         integer i,j,k
17923 !C      write(2,*) "ivec",ivec_start,ivec_end
17924       do i=1,nres
17925         fac_shield(i)=0.0d0
17926         do j=1,3
17927         grad_shield(j,i)=0.0d0
17928         enddo
17929       enddo
17930       do i=ivec_start,ivec_end
17931 !C      do i=1,nres-1
17932 !C      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
17933       ishield_list(i)=0
17934       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
17935 !Cif there two consequtive dummy atoms there is no peptide group between them
17936 !C the line below has to be changed for FGPROC>1
17937       VolumeTotal=0.0
17938       do k=1,nres
17939        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
17940        dist_pep_side=0.0
17941        dist_side_calf=0.0
17942        do j=1,3
17943 !C first lets set vector conecting the ithe side-chain with kth side-chain
17944       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
17945 !C      pep_side(j)=2.0d0
17946 !C and vector conecting the side-chain with its proper calfa
17947       side_calf(j)=c(j,k+nres)-c(j,k)
17948 !C      side_calf(j)=2.0d0
17949       pept_group(j)=c(j,i)-c(j,i+1)
17950 !C lets have their lenght
17951       dist_pep_side=pep_side(j)**2+dist_pep_side
17952       dist_side_calf=dist_side_calf+side_calf(j)**2
17953       dist_pept_group=dist_pept_group+pept_group(j)**2
17954       enddo
17955        dist_pep_side=sqrt(dist_pep_side)
17956        dist_pept_group=sqrt(dist_pept_group)
17957        dist_side_calf=sqrt(dist_side_calf)
17958       do j=1,3
17959         pep_side_norm(j)=pep_side(j)/dist_pep_side
17960         side_calf_norm(j)=dist_side_calf
17961       enddo
17962 !C now sscale fraction
17963        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
17964 !C       print *,buff_shield,"buff"
17965 !C now sscale
17966         if (sh_frac_dist.le.0.0) cycle
17967 !C        print *,ishield_list(i),i
17968 !C If we reach here it means that this side chain reaches the shielding sphere
17969 !C Lets add him to the list for gradient
17970         ishield_list(i)=ishield_list(i)+1
17971 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
17972 !C this list is essential otherwise problem would be O3
17973         shield_list(ishield_list(i),i)=k
17974 !C Lets have the sscale value
17975         if (sh_frac_dist.gt.1.0) then
17976          scale_fac_dist=1.0d0
17977          do j=1,3
17978          sh_frac_dist_grad(j)=0.0d0
17979          enddo
17980         else
17981          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
17982                         *(2.0d0*sh_frac_dist-3.0d0)
17983          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
17984                        /dist_pep_side/buff_shield*0.5d0
17985          do j=1,3
17986          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
17987 !C         sh_frac_dist_grad(j)=0.0d0
17988 !C         scale_fac_dist=1.0d0
17989 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
17990 !C     &                    sh_frac_dist_grad(j)
17991          enddo
17992         endif
17993 !C this is what is now we have the distance scaling now volume...
17994       short=short_r_sidechain(itype(k))
17995       long=long_r_sidechain(itype(k))
17996       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
17997       sinthet=short/dist_pep_side*costhet
17998 !C now costhet_grad
17999 !C       costhet=0.6d0
18000 !C       sinthet=0.8
18001        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
18002 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
18003 !C     &             -short/dist_pep_side**2/costhet)
18004 !C       costhet_fac=0.0d0
18005        do j=1,3
18006          costhet_grad(j)=costhet_fac*pep_side(j)
18007        enddo
18008 !C remember for the final gradient multiply costhet_grad(j)
18009 !C for side_chain by factor -2 !
18010 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
18011 !C pep_side0pept_group is vector multiplication
18012       pep_side0pept_group=0.0d0
18013       do j=1,3
18014       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
18015       enddo
18016       cosalfa=(pep_side0pept_group/ &
18017       (dist_pep_side*dist_side_calf))
18018       fac_alfa_sin=1.0d0-cosalfa**2
18019       fac_alfa_sin=dsqrt(fac_alfa_sin)
18020       rkprim=fac_alfa_sin*(long-short)+short
18021 !C      rkprim=short
18022
18023 !C now costhet_grad
18024        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
18025 !C       cosphi=0.6
18026        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
18027        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
18028            dist_pep_side**2)
18029 !C       sinphi=0.8
18030        do j=1,3
18031          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
18032       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
18033       *(long-short)/fac_alfa_sin*cosalfa/ &
18034       ((dist_pep_side*dist_side_calf))* &
18035       ((side_calf(j))-cosalfa* &
18036       ((pep_side(j)/dist_pep_side)*dist_side_calf))
18037 !C       cosphi_grad_long(j)=0.0d0
18038         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
18039       *(long-short)/fac_alfa_sin*cosalfa &
18040       /((dist_pep_side*dist_side_calf))* &
18041       (pep_side(j)- &
18042       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
18043 !C       cosphi_grad_loc(j)=0.0d0
18044        enddo
18045 !C      print *,sinphi,sinthet
18046       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
18047      &                    /VSolvSphere_div
18048 !C     &                    *wshield
18049 !C now the gradient...
18050       do j=1,3
18051       grad_shield(j,i)=grad_shield(j,i) &
18052 !C gradient po skalowaniu
18053                      +(sh_frac_dist_grad(j)*VofOverlap &
18054 !C  gradient po costhet
18055             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
18056         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
18057             sinphi/sinthet*costhet*costhet_grad(j) &
18058            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
18059         )*wshield
18060 !C grad_shield_side is Cbeta sidechain gradient
18061       grad_shield_side(j,ishield_list(i),i)=&
18062              (sh_frac_dist_grad(j)*-2.0d0&
18063              *VofOverlap&
18064             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
18065        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
18066             sinphi/sinthet*costhet*costhet_grad(j)&
18067            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
18068             )*wshield
18069
18070        grad_shield_loc(j,ishield_list(i),i)=   &
18071             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
18072       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
18073             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
18074              ))&
18075              *wshield
18076       enddo
18077       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
18078       enddo
18079       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
18080
18081 !C      write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
18082       enddo
18083       return
18084       end subroutine set_shield_fac2
18085
18086 !-----------------------------------------------------------------------------
18087 #ifdef WHAM
18088       subroutine read_ssHist
18089 !      implicit none
18090 !      Includes
18091 !      include 'DIMENSIONS'
18092 !      include "DIMENSIONS.FREE"
18093 !      include 'COMMON.FREE'
18094 !     Local variables
18095       integer :: i,j
18096       character(len=80) :: controlcard
18097
18098       do i=1,dyn_nssHist
18099         call card_concat(controlcard,.true.)
18100         read(controlcard,*) &
18101              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
18102       enddo
18103
18104       return
18105       end subroutine read_ssHist
18106 #endif
18107 !-----------------------------------------------------------------------------
18108       integer function indmat(i,j)
18109 !el
18110 ! get the position of the jth ijth fragment of the chain coordinate system
18111 ! in the fromto array.
18112         integer :: i,j
18113
18114         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
18115       return
18116       end function indmat
18117 !-----------------------------------------------------------------------------
18118       real(kind=8) function sigm(x)
18119 !el
18120        real(kind=8) :: x
18121         sigm=0.25d0*x
18122       return
18123       end function sigm
18124 !-----------------------------------------------------------------------------
18125 !-----------------------------------------------------------------------------
18126       subroutine alloc_ener_arrays
18127 !EL Allocation of arrays used by module energy
18128       use MD_data, only: mset
18129 !el local variables
18130       integer :: i,j
18131
18132       if(nres.lt.100) then
18133         maxconts=nres
18134       elseif(nres.lt.200) then
18135         maxconts=0.8*nres       ! Max. number of contacts per residue
18136       else
18137         maxconts=0.6*nres ! (maxconts=maxres/4)
18138       endif
18139       maxcont=12*nres   ! Max. number of SC contacts
18140       maxvar=6*nres     ! Max. number of variables
18141 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
18142       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
18143 !----------------------
18144 ! arrays in subroutine init_int_table
18145 !el#ifdef MPI
18146 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
18147 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
18148 !el#endif
18149       allocate(nint_gr(nres))
18150       allocate(nscp_gr(nres))
18151       allocate(ielstart(nres))
18152       allocate(ielend(nres))
18153 !(maxres)
18154       allocate(istart(nres,maxint_gr))
18155       allocate(iend(nres,maxint_gr))
18156 !(maxres,maxint_gr)
18157       allocate(iscpstart(nres,maxint_gr))
18158       allocate(iscpend(nres,maxint_gr))
18159 !(maxres,maxint_gr)
18160       allocate(ielstart_vdw(nres))
18161       allocate(ielend_vdw(nres))
18162 !(maxres)
18163
18164       allocate(lentyp(0:nfgtasks-1))
18165 !(0:maxprocs-1)
18166 !----------------------
18167 ! commom.contacts
18168 !      common /contacts/
18169       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
18170       allocate(icont(2,maxcont))
18171 !(2,maxcont)
18172 !      common /contacts1/
18173       allocate(num_cont(0:nres+4))
18174 !(maxres)
18175       allocate(jcont(maxconts,nres))
18176 !(maxconts,maxres)
18177       allocate(facont(maxconts,nres))
18178 !(maxconts,maxres)
18179       allocate(gacont(3,maxconts,nres))
18180 !(3,maxconts,maxres)
18181 !      common /contacts_hb/
18182       allocate(gacontp_hb1(3,maxconts,nres))
18183       allocate(gacontp_hb2(3,maxconts,nres))
18184       allocate(gacontp_hb3(3,maxconts,nres))
18185       allocate(gacontm_hb1(3,maxconts,nres))
18186       allocate(gacontm_hb2(3,maxconts,nres))
18187       allocate(gacontm_hb3(3,maxconts,nres))
18188       allocate(gacont_hbr(3,maxconts,nres))
18189       allocate(grij_hb_cont(3,maxconts,nres))
18190 !(3,maxconts,maxres)
18191       allocate(facont_hb(maxconts,nres))
18192
18193       allocate(ees0p(maxconts,nres))
18194       allocate(ees0m(maxconts,nres))
18195       allocate(d_cont(maxconts,nres))
18196       allocate(ees0plist(maxconts,nres))
18197
18198 !(maxconts,maxres)
18199       allocate(num_cont_hb(nres))
18200 !(maxres)
18201       allocate(jcont_hb(maxconts,nres))
18202 !(maxconts,maxres)
18203 !      common /rotat/
18204       allocate(Ug(2,2,nres))
18205       allocate(Ugder(2,2,nres))
18206       allocate(Ug2(2,2,nres))
18207       allocate(Ug2der(2,2,nres))
18208 !(2,2,maxres)
18209       allocate(obrot(2,nres))
18210       allocate(obrot2(2,nres))
18211       allocate(obrot_der(2,nres))
18212       allocate(obrot2_der(2,nres))
18213 !(2,maxres)
18214 !      common /precomp1/
18215       allocate(mu(2,nres))
18216       allocate(muder(2,nres))
18217       allocate(Ub2(2,nres))
18218       Ub2(1,:)=0.0d0
18219       Ub2(2,:)=0.0d0
18220       allocate(Ub2der(2,nres))
18221       allocate(Ctobr(2,nres))
18222       allocate(Ctobrder(2,nres))
18223       allocate(Dtobr2(2,nres))
18224       allocate(Dtobr2der(2,nres))
18225 !(2,maxres)
18226       allocate(EUg(2,2,nres))
18227       allocate(EUgder(2,2,nres))
18228       allocate(CUg(2,2,nres))
18229       allocate(CUgder(2,2,nres))
18230       allocate(DUg(2,2,nres))
18231       allocate(Dugder(2,2,nres))
18232       allocate(DtUg2(2,2,nres))
18233       allocate(DtUg2der(2,2,nres))
18234 !(2,2,maxres)
18235 !      common /precomp2/
18236       allocate(Ug2Db1t(2,nres))
18237       allocate(Ug2Db1tder(2,nres))
18238       allocate(CUgb2(2,nres))
18239       allocate(CUgb2der(2,nres))
18240 !(2,maxres)
18241       allocate(EUgC(2,2,nres))
18242       allocate(EUgCder(2,2,nres))
18243       allocate(EUgD(2,2,nres))
18244       allocate(EUgDder(2,2,nres))
18245       allocate(DtUg2EUg(2,2,nres))
18246       allocate(Ug2DtEUg(2,2,nres))
18247 !(2,2,maxres)
18248       allocate(Ug2DtEUgder(2,2,2,nres))
18249       allocate(DtUg2EUgder(2,2,2,nres))
18250 !(2,2,2,maxres)
18251 !      common /rotat_old/
18252       allocate(costab(nres))
18253       allocate(sintab(nres))
18254       allocate(costab2(nres))
18255       allocate(sintab2(nres))
18256 !(maxres)
18257 !      common /dipmat/
18258       allocate(a_chuj(2,2,maxconts,nres))
18259 !(2,2,maxconts,maxres)(maxconts=maxres/4)
18260       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
18261 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
18262 !      common /contdistrib/
18263       allocate(ncont_sent(nres))
18264       allocate(ncont_recv(nres))
18265
18266       allocate(iat_sent(nres))
18267 !(maxres)
18268       allocate(iint_sent(4,nres,nres))
18269       allocate(iint_sent_local(4,nres,nres))
18270 !(4,maxres,maxres)
18271       allocate(iturn3_sent(4,0:nres+4))
18272       allocate(iturn4_sent(4,0:nres+4))
18273       allocate(iturn3_sent_local(4,nres))
18274       allocate(iturn4_sent_local(4,nres))
18275 !(4,maxres)
18276       allocate(itask_cont_from(0:nfgtasks-1))
18277       allocate(itask_cont_to(0:nfgtasks-1))
18278 !(0:max_fg_procs-1)
18279
18280
18281
18282 !----------------------
18283 ! commom.deriv;
18284 !      common /derivat/
18285       allocate(dcdv(6,maxdim))
18286       allocate(dxdv(6,maxdim))
18287 !(6,maxdim)
18288       allocate(dxds(6,nres))
18289 !(6,maxres)
18290       allocate(gradx(3,-1:nres,0:2))
18291       allocate(gradc(3,-1:nres,0:2))
18292 !(3,maxres,2)
18293       allocate(gvdwx(3,-1:nres))
18294       allocate(gvdwc(3,-1:nres))
18295       allocate(gelc(3,-1:nres))
18296       allocate(gelc_long(3,-1:nres))
18297       allocate(gvdwpp(3,-1:nres))
18298       allocate(gvdwc_scpp(3,-1:nres))
18299       allocate(gradx_scp(3,-1:nres))
18300       allocate(gvdwc_scp(3,-1:nres))
18301       allocate(ghpbx(3,-1:nres))
18302       allocate(ghpbc(3,-1:nres))
18303       allocate(gradcorr(3,-1:nres))
18304       allocate(gradcorr_long(3,-1:nres))
18305       allocate(gradcorr5_long(3,-1:nres))
18306       allocate(gradcorr6_long(3,-1:nres))
18307       allocate(gcorr6_turn_long(3,-1:nres))
18308       allocate(gradxorr(3,-1:nres))
18309       allocate(gradcorr5(3,-1:nres))
18310       allocate(gradcorr6(3,-1:nres))
18311       allocate(gliptran(3,-1:nres))
18312       allocate(gliptranc(3,-1:nres))
18313       allocate(gliptranx(3,-1:nres))
18314       allocate(gshieldx(3,-1:nres))
18315       allocate(gshieldc(3,-1:nres))
18316       allocate(gshieldc_loc(3,-1:nres))
18317       allocate(gshieldx_ec(3,-1:nres))
18318       allocate(gshieldc_ec(3,-1:nres))
18319       allocate(gshieldc_loc_ec(3,-1:nres))
18320       allocate(gshieldx_t3(3,-1:nres))
18321       allocate(gshieldc_t3(3,-1:nres))
18322       allocate(gshieldc_loc_t3(3,-1:nres))
18323       allocate(gshieldx_t4(3,-1:nres))
18324       allocate(gshieldc_t4(3,-1:nres))
18325       allocate(gshieldc_loc_t4(3,-1:nres))
18326       allocate(gshieldx_ll(3,-1:nres))
18327       allocate(gshieldc_ll(3,-1:nres))
18328       allocate(gshieldc_loc_ll(3,-1:nres))
18329       allocate(grad_shield(3,-1:nres))
18330 !(3,maxres)
18331       allocate(grad_shield_side(3,50,nres))
18332       allocate(grad_shield_loc(3,50,nres))
18333 ! grad for shielding surroing
18334       allocate(gloc(0:maxvar,0:2))
18335       allocate(gloc_x(0:maxvar,2))
18336 !(maxvar,2)
18337       allocate(gel_loc(3,-1:nres))
18338       allocate(gel_loc_long(3,-1:nres))
18339       allocate(gcorr3_turn(3,-1:nres))
18340       allocate(gcorr4_turn(3,-1:nres))
18341       allocate(gcorr6_turn(3,-1:nres))
18342       allocate(gradb(3,-1:nres))
18343       allocate(gradbx(3,-1:nres))
18344 !(3,maxres)
18345       allocate(gel_loc_loc(maxvar))
18346       allocate(gel_loc_turn3(maxvar))
18347       allocate(gel_loc_turn4(maxvar))
18348       allocate(gel_loc_turn6(maxvar))
18349       allocate(gcorr_loc(maxvar))
18350       allocate(g_corr5_loc(maxvar))
18351       allocate(g_corr6_loc(maxvar))
18352 !(maxvar)
18353       allocate(gsccorc(3,-1:nres))
18354       allocate(gsccorx(3,-1:nres))
18355 !(3,maxres)
18356       allocate(gsccor_loc(-1:nres))
18357 !(maxres)
18358       allocate(dtheta(3,2,-1:nres))
18359 !(3,2,maxres)
18360       allocate(gscloc(3,-1:nres))
18361       allocate(gsclocx(3,-1:nres))
18362 !(3,maxres)
18363       allocate(dphi(3,3,-1:nres))
18364       allocate(dalpha(3,3,-1:nres))
18365       allocate(domega(3,3,-1:nres))
18366 !(3,3,maxres)
18367 !      common /deriv_scloc/
18368       allocate(dXX_C1tab(3,nres))
18369       allocate(dYY_C1tab(3,nres))
18370       allocate(dZZ_C1tab(3,nres))
18371       allocate(dXX_Ctab(3,nres))
18372       allocate(dYY_Ctab(3,nres))
18373       allocate(dZZ_Ctab(3,nres))
18374       allocate(dXX_XYZtab(3,nres))
18375       allocate(dYY_XYZtab(3,nres))
18376       allocate(dZZ_XYZtab(3,nres))
18377 !(3,maxres)
18378 !      common /mpgrad/
18379       allocate(jgrad_start(nres))
18380       allocate(jgrad_end(nres))
18381 !(maxres)
18382 !----------------------
18383
18384 !      common /indices/
18385       allocate(ibond_displ(0:nfgtasks-1))
18386       allocate(ibond_count(0:nfgtasks-1))
18387       allocate(ithet_displ(0:nfgtasks-1))
18388       allocate(ithet_count(0:nfgtasks-1))
18389       allocate(iphi_displ(0:nfgtasks-1))
18390       allocate(iphi_count(0:nfgtasks-1))
18391       allocate(iphi1_displ(0:nfgtasks-1))
18392       allocate(iphi1_count(0:nfgtasks-1))
18393       allocate(ivec_displ(0:nfgtasks-1))
18394       allocate(ivec_count(0:nfgtasks-1))
18395       allocate(iset_displ(0:nfgtasks-1))
18396       allocate(iset_count(0:nfgtasks-1))
18397       allocate(iint_count(0:nfgtasks-1))
18398       allocate(iint_displ(0:nfgtasks-1))
18399 !(0:max_fg_procs-1)
18400 !----------------------
18401 ! common.MD
18402 !      common /mdgrad/
18403       allocate(gcart(3,-1:nres))
18404       allocate(gxcart(3,-1:nres))
18405 !(3,0:MAXRES)
18406       allocate(gradcag(3,-1:nres))
18407       allocate(gradxag(3,-1:nres))
18408 !(3,MAXRES)
18409 !      common /back_constr/
18410 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
18411       allocate(dutheta(nres))
18412       allocate(dugamma(nres))
18413 !(maxres)
18414       allocate(duscdiff(3,nres))
18415       allocate(duscdiffx(3,nres))
18416 !(3,maxres)
18417 !el i io:read_fragments
18418 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
18419 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
18420 !      common /qmeas/
18421 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
18422 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
18423       allocate(mset(0:nprocs))  !(maxprocs/20)
18424       mset(:)=0
18425 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
18426 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
18427       allocate(dUdconst(3,0:nres))
18428       allocate(dUdxconst(3,0:nres))
18429       allocate(dqwol(3,0:nres))
18430       allocate(dxqwol(3,0:nres))
18431 !(3,0:MAXRES)
18432 !----------------------
18433 ! common.sbridge
18434 !      common /sbridge/ in io_common: read_bridge
18435 !el    allocate((:),allocatable :: iss  !(maxss)
18436 !      common /links/  in io_common: read_bridge
18437 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
18438 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
18439 !      common /dyn_ssbond/
18440 ! and side-chain vectors in theta or phi.
18441       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
18442 !(maxres,maxres)
18443 !      do i=1,nres
18444 !        do j=i+1,nres
18445       dyn_ssbond_ij(:,:)=1.0d300
18446 !        enddo
18447 !      enddo
18448
18449       if (nss.gt.0) then
18450         allocate(idssb(nss),jdssb(nss))
18451 !(maxdim)
18452       endif
18453       allocate(ishield_list(nres))
18454       allocate(shield_list(50,nres))
18455       allocate(dyn_ss_mask(nres))
18456       allocate(fac_shield(nres))
18457 !(maxres)
18458       dyn_ss_mask(:)=.false.
18459 !----------------------
18460 ! common.sccor
18461 ! Parameters of the SCCOR term
18462 !      common/sccor/
18463 !el in io_conf: parmread
18464 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
18465 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
18466 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
18467 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
18468 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
18469 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
18470 !      allocate(vlor1sccor(maxterm_sccor,20,20))
18471 !      allocate(vlor2sccor(maxterm_sccor,20,20))
18472 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
18473 !----------------
18474       allocate(gloc_sc(3,0:2*nres,0:10))
18475 !(3,0:maxres2,10)maxres2=2*maxres
18476       allocate(dcostau(3,3,3,2*nres))
18477       allocate(dsintau(3,3,3,2*nres))
18478       allocate(dtauangle(3,3,3,2*nres))
18479       allocate(dcosomicron(3,3,3,2*nres))
18480       allocate(domicron(3,3,3,2*nres))
18481 !(3,3,3,maxres2)maxres2=2*maxres
18482 !----------------------
18483 ! common.var
18484 !      common /restr/
18485       allocate(varall(maxvar))
18486 !(maxvar)(maxvar=6*maxres)
18487       allocate(mask_theta(nres))
18488       allocate(mask_phi(nres))
18489       allocate(mask_side(nres))
18490 !(maxres)
18491 !----------------------
18492 ! common.vectors
18493 !      common /vectors/
18494       allocate(uy(3,nres))
18495       allocate(uz(3,nres))
18496 !(3,maxres)
18497       allocate(uygrad(3,3,2,nres))
18498       allocate(uzgrad(3,3,2,nres))
18499 !(3,3,2,maxres)
18500
18501       return
18502       end subroutine alloc_ener_arrays
18503 !-----------------------------------------------------------------------------
18504 !-----------------------------------------------------------------------------
18505       end module energy