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         print *,"I am in EVDW",i
1332         itypi=iabs(itype(i))
1333         if (itypi.eq.ntyp1) cycle
1334         itypi1=iabs(itype(i+1))
1335         xi=c(1,nres+i)
1336         yi=c(2,nres+i)
1337         zi=c(3,nres+i)
1338           xi=dmod(xi,boxxsize)
1339           if (xi.lt.0) xi=xi+boxxsize
1340           yi=dmod(yi,boxysize)
1341           if (yi.lt.0) yi=yi+boxysize
1342           zi=dmod(zi,boxzsize)
1343           if (zi.lt.0) zi=zi+boxzsize
1344
1345        if ((zi.gt.bordlipbot)  &
1346         .and.(zi.lt.bordliptop)) then
1347 !C the energy transfer exist
1348         if (zi.lt.buflipbot) then
1349 !C what fraction I am in
1350          fracinbuf=1.0d0-  &
1351               ((zi-bordlipbot)/lipbufthick)
1352 !C lipbufthick is thickenes of lipid buffore
1353          sslipi=sscalelip(fracinbuf)
1354          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1355         elseif (zi.gt.bufliptop) then
1356          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1357          sslipi=sscalelip(fracinbuf)
1358          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1359         else
1360          sslipi=1.0d0
1361          ssgradlipi=0.0
1362         endif
1363        else
1364          sslipi=0.0d0
1365          ssgradlipi=0.0
1366        endif
1367        print *, sslipi,ssgradlipi
1368         dxi=dc_norm(1,nres+i)
1369         dyi=dc_norm(2,nres+i)
1370         dzi=dc_norm(3,nres+i)
1371 !        dsci_inv=dsc_inv(itypi)
1372         dsci_inv=vbld_inv(i+nres)
1373 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1374 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1375 !
1376 ! Calculate SC interaction energy.
1377 !
1378         do iint=1,nint_gr(i)
1379           do j=istart(i,iint),iend(i,iint)
1380             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1381               call dyn_ssbond_ene(i,j,evdwij)
1382               evdw=evdw+evdwij
1383               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1384                               'evdw',i,j,evdwij,' ss'
1385 !              if (energy_dec) write (iout,*) &
1386 !                              'evdw',i,j,evdwij,' ss'
1387             ELSE
1388 !el            ind=ind+1
1389             itypj=iabs(itype(j))
1390             if (itypj.eq.ntyp1) cycle
1391 !            dscj_inv=dsc_inv(itypj)
1392             dscj_inv=vbld_inv(j+nres)
1393 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1394 !              1.0d0/vbld(j+nres) !d
1395 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1396             sig0ij=sigma(itypi,itypj)
1397             chi1=chi(itypi,itypj)
1398             chi2=chi(itypj,itypi)
1399             chi12=chi1*chi2
1400             chip1=chip(itypi)
1401             chip2=chip(itypj)
1402             chip12=chip1*chip2
1403             alf1=alp(itypi)
1404             alf2=alp(itypj)
1405             alf12=0.5D0*(alf1+alf2)
1406 ! For diagnostics only!!!
1407 !           chi1=0.0D0
1408 !           chi2=0.0D0
1409 !           chi12=0.0D0
1410 !           chip1=0.0D0
1411 !           chip2=0.0D0
1412 !           chip12=0.0D0
1413 !           alf1=0.0D0
1414 !           alf2=0.0D0
1415 !           alf12=0.0D0
1416            xj=c(1,nres+j)
1417            yj=c(2,nres+j)
1418            zj=c(3,nres+j)
1419           xj=dmod(xj,boxxsize)
1420           if (xj.lt.0) xj=xj+boxxsize
1421           yj=dmod(yj,boxysize)
1422           if (yj.lt.0) yj=yj+boxysize
1423           zj=dmod(zj,boxzsize)
1424           if (zj.lt.0) zj=zj+boxzsize
1425 !          print *,"tu",xi,yi,zi,xj,yj,zj
1426 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1427 ! this fragment set correct epsilon for lipid phase
1428        if ((zj.gt.bordlipbot)  &
1429        .and.(zj.lt.bordliptop)) then
1430 !C the energy transfer exist
1431         if (zj.lt.buflipbot) then
1432 !C what fraction I am in
1433          fracinbuf=1.0d0-     &
1434              ((zj-bordlipbot)/lipbufthick)
1435 !C lipbufthick is thickenes of lipid buffore
1436          sslipj=sscalelip(fracinbuf)
1437          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1438         elseif (zj.gt.bufliptop) then
1439          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1440          sslipj=sscalelip(fracinbuf)
1441          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1442         else
1443          sslipj=1.0d0
1444          ssgradlipj=0.0
1445         endif
1446        else
1447          sslipj=0.0d0
1448          ssgradlipj=0.0
1449        endif
1450       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1451        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1452       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1453        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1454 !------------------------------------------------
1455       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1456       xj_safe=xj
1457       yj_safe=yj
1458       zj_safe=zj
1459       subchap=0
1460       do xshift=-1,1
1461       do yshift=-1,1
1462       do zshift=-1,1
1463           xj=xj_safe+xshift*boxxsize
1464           yj=yj_safe+yshift*boxysize
1465           zj=zj_safe+zshift*boxzsize
1466           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1467           if(dist_temp.lt.dist_init) then
1468             dist_init=dist_temp
1469             xj_temp=xj
1470             yj_temp=yj
1471             zj_temp=zj
1472             subchap=1
1473           endif
1474        enddo
1475        enddo
1476        enddo
1477        if (subchap.eq.1) then
1478           xj=xj_temp-xi
1479           yj=yj_temp-yi
1480           zj=zj_temp-zi
1481        else
1482           xj=xj_safe-xi
1483           yj=yj_safe-yi
1484           zj=zj_safe-zi
1485        endif
1486             dxj=dc_norm(1,nres+j)
1487             dyj=dc_norm(2,nres+j)
1488             dzj=dc_norm(3,nres+j)
1489 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1490 !            write (iout,*) "j",j," dc_norm",& !d
1491 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1492 !          write(iout,*)"rrij ",rrij
1493 !          write(iout,*)"xj yj zj ", xj, yj, zj
1494 !          write(iout,*)"xi yi zi ", xi, yi, zi
1495 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1496             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1497             rij=dsqrt(rrij)
1498             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1499             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1500 !            print *,sss_ele_cut,sss_ele_grad,&
1501 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1502             if (sss_ele_cut.le.0.0) cycle
1503 ! Calculate angle-dependent terms of energy and contributions to their
1504 ! derivatives.
1505             call sc_angular
1506             sigsq=1.0D0/sigsq
1507             sig=sig0ij*dsqrt(sigsq)
1508             rij_shift=1.0D0/rij-sig+sig0ij
1509 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1510 !            "sig0ij",sig0ij
1511 ! for diagnostics; uncomment
1512 !            rij_shift=1.2*sig0ij
1513 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1514             if (rij_shift.le.0.0D0) then
1515               evdw=1.0D20
1516 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1517 !d     &        restyp(itypi),i,restyp(itypj),j,
1518 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1519               return
1520             endif
1521             sigder=-sig*sigsq
1522 !---------------------------------------------------------------
1523             rij_shift=1.0D0/rij_shift
1524             fac=rij_shift**expon
1525             faclip=fac
1526             e1=fac*fac*aa!(itypi,itypj)
1527             e2=fac*bb!(itypi,itypj)
1528             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1529             eps2der=evdwij*eps3rt
1530             eps3der=evdwij*eps2rt
1531 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1532 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1533 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1534             evdwij=evdwij*eps2rt*eps3rt
1535             evdw=evdw+evdwij*sss_ele_cut
1536             if (lprn) then
1537             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1538             epsi=bb**2/aa!(itypi,itypj)
1539             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1540               restyp(itypi),i,restyp(itypj),j, &
1541               epsi,sigm,chi1,chi2,chip1,chip2, &
1542               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1543               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1544               evdwij
1545             endif
1546
1547             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1548                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1549 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1550 !            if (energy_dec) write (iout,*) &
1551 !                             'evdw',i,j,evdwij
1552
1553 ! Calculate gradient components.
1554             e1=e1*eps1*eps2rt**2*eps3rt**2
1555             fac=-expon*(e1+evdwij)*rij_shift
1556             sigder=fac*sigder
1557             fac=rij*fac
1558 !            print *,'before fac',fac,rij,evdwij
1559             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1560             /sigma(itypi,itypj)*rij
1561 !            print *,'grad part scale',fac,   &
1562 !             evdwij*sss_ele_grad/sss_ele_cut &
1563 !            /sigma(itypi,itypj)*rij
1564 !            fac=0.0d0
1565 ! Calculate the radial part of the gradient
1566             gg(1)=xj*fac
1567             gg(2)=yj*fac
1568             gg(3)=zj*fac
1569 !C Calculate the radial part of the gradient
1570             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1571        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1572         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1573        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1574             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1575             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1576
1577 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1578 ! Calculate angular part of the gradient.
1579             call sc_grad
1580             ENDIF    ! dyn_ss
1581           enddo      ! j
1582         enddo        ! iint
1583       enddo          ! i
1584 !      write (iout,*) "Number of loop steps in EGB:",ind
1585 !ccc      energy_dec=.false.
1586       return
1587       end subroutine egb
1588 !-----------------------------------------------------------------------------
1589       subroutine egbv(evdw)
1590 !
1591 ! This subroutine calculates the interaction energy of nonbonded side chains
1592 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1593 !
1594       use comm_srutu
1595       use calc_data
1596 !      implicit real*8 (a-h,o-z)
1597 !      include 'DIMENSIONS'
1598 !      include 'COMMON.GEO'
1599 !      include 'COMMON.VAR'
1600 !      include 'COMMON.LOCAL'
1601 !      include 'COMMON.CHAIN'
1602 !      include 'COMMON.DERIV'
1603 !      include 'COMMON.NAMES'
1604 !      include 'COMMON.INTERACT'
1605 !      include 'COMMON.IOUNITS'
1606 !      include 'COMMON.CALC'
1607       use comm_srutu
1608 !el      integer :: icall
1609 !el      common /srutu/ icall
1610       logical :: lprn
1611 !el local variables
1612       integer :: iint,itypi,itypi1,itypj
1613       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1614       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1615
1616 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1617       evdw=0.0D0
1618       lprn=.false.
1619 !     if (icall.eq.0) lprn=.true.
1620 !el      ind=0
1621       do i=iatsc_s,iatsc_e
1622         itypi=iabs(itype(i))
1623         if (itypi.eq.ntyp1) cycle
1624         itypi1=iabs(itype(i+1))
1625         xi=c(1,nres+i)
1626         yi=c(2,nres+i)
1627         zi=c(3,nres+i)
1628         dxi=dc_norm(1,nres+i)
1629         dyi=dc_norm(2,nres+i)
1630         dzi=dc_norm(3,nres+i)
1631 !        dsci_inv=dsc_inv(itypi)
1632         dsci_inv=vbld_inv(i+nres)
1633 !
1634 ! Calculate SC interaction energy.
1635 !
1636         do iint=1,nint_gr(i)
1637           do j=istart(i,iint),iend(i,iint)
1638 !el            ind=ind+1
1639             itypj=iabs(itype(j))
1640             if (itypj.eq.ntyp1) cycle
1641 !            dscj_inv=dsc_inv(itypj)
1642             dscj_inv=vbld_inv(j+nres)
1643             sig0ij=sigma(itypi,itypj)
1644             r0ij=r0(itypi,itypj)
1645             chi1=chi(itypi,itypj)
1646             chi2=chi(itypj,itypi)
1647             chi12=chi1*chi2
1648             chip1=chip(itypi)
1649             chip2=chip(itypj)
1650             chip12=chip1*chip2
1651             alf1=alp(itypi)
1652             alf2=alp(itypj)
1653             alf12=0.5D0*(alf1+alf2)
1654 ! For diagnostics only!!!
1655 !           chi1=0.0D0
1656 !           chi2=0.0D0
1657 !           chi12=0.0D0
1658 !           chip1=0.0D0
1659 !           chip2=0.0D0
1660 !           chip12=0.0D0
1661 !           alf1=0.0D0
1662 !           alf2=0.0D0
1663 !           alf12=0.0D0
1664             xj=c(1,nres+j)-xi
1665             yj=c(2,nres+j)-yi
1666             zj=c(3,nres+j)-zi
1667             dxj=dc_norm(1,nres+j)
1668             dyj=dc_norm(2,nres+j)
1669             dzj=dc_norm(3,nres+j)
1670             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1671             rij=dsqrt(rrij)
1672 ! Calculate angle-dependent terms of energy and contributions to their
1673 ! derivatives.
1674             call sc_angular
1675             sigsq=1.0D0/sigsq
1676             sig=sig0ij*dsqrt(sigsq)
1677             rij_shift=1.0D0/rij-sig+r0ij
1678 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1679             if (rij_shift.le.0.0D0) then
1680               evdw=1.0D20
1681               return
1682             endif
1683             sigder=-sig*sigsq
1684 !---------------------------------------------------------------
1685             rij_shift=1.0D0/rij_shift
1686             fac=rij_shift**expon
1687             e1=fac*fac*aa_aq(itypi,itypj)
1688             e2=fac*bb_aq(itypi,itypj)
1689             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1690             eps2der=evdwij*eps3rt
1691             eps3der=evdwij*eps2rt
1692             fac_augm=rrij**expon
1693             e_augm=augm(itypi,itypj)*fac_augm
1694             evdwij=evdwij*eps2rt*eps3rt
1695             evdw=evdw+evdwij+e_augm
1696             if (lprn) then
1697             sigm=dabs(aa_aq(itypi,itypj)/&
1698             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1699             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1700             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1701               restyp(itypi),i,restyp(itypj),j,&
1702               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1703               chi1,chi2,chip1,chip2,&
1704               eps1,eps2rt**2,eps3rt**2,&
1705               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1706               evdwij+e_augm
1707             endif
1708 ! Calculate gradient components.
1709             e1=e1*eps1*eps2rt**2*eps3rt**2
1710             fac=-expon*(e1+evdwij)*rij_shift
1711             sigder=fac*sigder
1712             fac=rij*fac-2*expon*rrij*e_augm
1713 ! Calculate the radial part of the gradient
1714             gg(1)=xj*fac
1715             gg(2)=yj*fac
1716             gg(3)=zj*fac
1717 ! Calculate angular part of the gradient.
1718             call sc_grad
1719           enddo      ! j
1720         enddo        ! iint
1721       enddo          ! i
1722       end subroutine egbv
1723 !-----------------------------------------------------------------------------
1724 !el      subroutine sc_angular in module geometry
1725 !-----------------------------------------------------------------------------
1726       subroutine e_softsphere(evdw)
1727 !
1728 ! This subroutine calculates the interaction energy of nonbonded side chains
1729 ! assuming the LJ potential of interaction.
1730 !
1731 !      implicit real*8 (a-h,o-z)
1732 !      include 'DIMENSIONS'
1733       real(kind=8),parameter :: accur=1.0d-10
1734 !      include 'COMMON.GEO'
1735 !      include 'COMMON.VAR'
1736 !      include 'COMMON.LOCAL'
1737 !      include 'COMMON.CHAIN'
1738 !      include 'COMMON.DERIV'
1739 !      include 'COMMON.INTERACT'
1740 !      include 'COMMON.TORSION'
1741 !      include 'COMMON.SBRIDGE'
1742 !      include 'COMMON.NAMES'
1743 !      include 'COMMON.IOUNITS'
1744 !      include 'COMMON.CONTACTS'
1745       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1746 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1747 !el local variables
1748       integer :: i,iint,j,itypi,itypi1,itypj,k
1749       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1750       real(kind=8) :: fac
1751
1752       evdw=0.0D0
1753       do i=iatsc_s,iatsc_e
1754         itypi=iabs(itype(i))
1755         if (itypi.eq.ntyp1) cycle
1756         itypi1=iabs(itype(i+1))
1757         xi=c(1,nres+i)
1758         yi=c(2,nres+i)
1759         zi=c(3,nres+i)
1760 !
1761 ! Calculate SC interaction energy.
1762 !
1763         do iint=1,nint_gr(i)
1764 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1765 !d   &                  'iend=',iend(i,iint)
1766           do j=istart(i,iint),iend(i,iint)
1767             itypj=iabs(itype(j))
1768             if (itypj.eq.ntyp1) cycle
1769             xj=c(1,nres+j)-xi
1770             yj=c(2,nres+j)-yi
1771             zj=c(3,nres+j)-zi
1772             rij=xj*xj+yj*yj+zj*zj
1773 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1774             r0ij=r0(itypi,itypj)
1775             r0ijsq=r0ij*r0ij
1776 !            print *,i,j,r0ij,dsqrt(rij)
1777             if (rij.lt.r0ijsq) then
1778               evdwij=0.25d0*(rij-r0ijsq)**2
1779               fac=rij-r0ijsq
1780             else
1781               evdwij=0.0d0
1782               fac=0.0d0
1783             endif
1784             evdw=evdw+evdwij
1785 !
1786 ! Calculate the components of the gradient in DC and X
1787 !
1788             gg(1)=xj*fac
1789             gg(2)=yj*fac
1790             gg(3)=zj*fac
1791             do k=1,3
1792               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1793               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1794               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1795               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1796             enddo
1797 !grad            do k=i,j-1
1798 !grad              do l=1,3
1799 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1800 !grad              enddo
1801 !grad            enddo
1802           enddo ! j
1803         enddo ! iint
1804       enddo ! i
1805       return
1806       end subroutine e_softsphere
1807 !-----------------------------------------------------------------------------
1808       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1809 !
1810 ! Soft-sphere potential of p-p interaction
1811 !
1812 !      implicit real*8 (a-h,o-z)
1813 !      include 'DIMENSIONS'
1814 !      include 'COMMON.CONTROL'
1815 !      include 'COMMON.IOUNITS'
1816 !      include 'COMMON.GEO'
1817 !      include 'COMMON.VAR'
1818 !      include 'COMMON.LOCAL'
1819 !      include 'COMMON.CHAIN'
1820 !      include 'COMMON.DERIV'
1821 !      include 'COMMON.INTERACT'
1822 !      include 'COMMON.CONTACTS'
1823 !      include 'COMMON.TORSION'
1824 !      include 'COMMON.VECTORS'
1825 !      include 'COMMON.FFIELD'
1826       real(kind=8),dimension(3) :: ggg
1827 !d      write(iout,*) 'In EELEC_soft_sphere'
1828 !el local variables
1829       integer :: i,j,k,num_conti,iteli,itelj
1830       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
1831       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
1832       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
1833
1834       ees=0.0D0
1835       evdw1=0.0D0
1836       eel_loc=0.0d0
1837       eello_turn3=0.0d0
1838       eello_turn4=0.0d0
1839 !el      ind=0
1840       do i=iatel_s,iatel_e
1841         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1842         dxi=dc(1,i)
1843         dyi=dc(2,i)
1844         dzi=dc(3,i)
1845         xmedi=c(1,i)+0.5d0*dxi
1846         ymedi=c(2,i)+0.5d0*dyi
1847         zmedi=c(3,i)+0.5d0*dzi
1848         num_conti=0
1849 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1850         do j=ielstart(i),ielend(i)
1851           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1852 !el          ind=ind+1
1853           iteli=itel(i)
1854           itelj=itel(j)
1855           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1856           r0ij=rpp(iteli,itelj)
1857           r0ijsq=r0ij*r0ij
1858           dxj=dc(1,j)
1859           dyj=dc(2,j)
1860           dzj=dc(3,j)
1861           xj=c(1,j)+0.5D0*dxj-xmedi
1862           yj=c(2,j)+0.5D0*dyj-ymedi
1863           zj=c(3,j)+0.5D0*dzj-zmedi
1864           rij=xj*xj+yj*yj+zj*zj
1865           if (rij.lt.r0ijsq) then
1866             evdw1ij=0.25d0*(rij-r0ijsq)**2
1867             fac=rij-r0ijsq
1868           else
1869             evdw1ij=0.0d0
1870             fac=0.0d0
1871           endif
1872           evdw1=evdw1+evdw1ij
1873 !
1874 ! Calculate contributions to the Cartesian gradient.
1875 !
1876           ggg(1)=fac*xj
1877           ggg(2)=fac*yj
1878           ggg(3)=fac*zj
1879           do k=1,3
1880             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1881             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1882           enddo
1883 !
1884 ! Loop over residues i+1 thru j-1.
1885 !
1886 !grad          do k=i+1,j-1
1887 !grad            do l=1,3
1888 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
1889 !grad            enddo
1890 !grad          enddo
1891         enddo ! j
1892       enddo   ! i
1893 !grad      do i=nnt,nct-1
1894 !grad        do k=1,3
1895 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1896 !grad        enddo
1897 !grad        do j=i+1,nct-1
1898 !grad          do k=1,3
1899 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1900 !grad          enddo
1901 !grad        enddo
1902 !grad      enddo
1903       return
1904       end subroutine eelec_soft_sphere
1905 !-----------------------------------------------------------------------------
1906       subroutine vec_and_deriv
1907 !      implicit real*8 (a-h,o-z)
1908 !      include 'DIMENSIONS'
1909 #ifdef MPI
1910       include 'mpif.h'
1911 #endif
1912 !      include 'COMMON.IOUNITS'
1913 !      include 'COMMON.GEO'
1914 !      include 'COMMON.VAR'
1915 !      include 'COMMON.LOCAL'
1916 !      include 'COMMON.CHAIN'
1917 !      include 'COMMON.VECTORS'
1918 !      include 'COMMON.SETUP'
1919 !      include 'COMMON.TIME1'
1920       real(kind=8),dimension(3,3,2) :: uyder,uzder
1921       real(kind=8),dimension(2) :: vbld_inv_temp
1922 ! Compute the local reference systems. For reference system (i), the
1923 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
1924 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1925 !el local variables
1926       integer :: i,j,k,l
1927       real(kind=8) :: facy,fac,costh
1928
1929 #ifdef PARVEC
1930       do i=ivec_start,ivec_end
1931 #else
1932       do i=1,nres-1
1933 #endif
1934           if (i.eq.nres-1) then
1935 ! Case of the last full residue
1936 ! Compute the Z-axis
1937             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1938             costh=dcos(pi-theta(nres))
1939             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1940             do k=1,3
1941               uz(k,i)=fac*uz(k,i)
1942             enddo
1943 ! Compute the derivatives of uz
1944             uzder(1,1,1)= 0.0d0
1945             uzder(2,1,1)=-dc_norm(3,i-1)
1946             uzder(3,1,1)= dc_norm(2,i-1)
1947             uzder(1,2,1)= dc_norm(3,i-1)
1948             uzder(2,2,1)= 0.0d0
1949             uzder(3,2,1)=-dc_norm(1,i-1)
1950             uzder(1,3,1)=-dc_norm(2,i-1)
1951             uzder(2,3,1)= dc_norm(1,i-1)
1952             uzder(3,3,1)= 0.0d0
1953             uzder(1,1,2)= 0.0d0
1954             uzder(2,1,2)= dc_norm(3,i)
1955             uzder(3,1,2)=-dc_norm(2,i)
1956             uzder(1,2,2)=-dc_norm(3,i)
1957             uzder(2,2,2)= 0.0d0
1958             uzder(3,2,2)= dc_norm(1,i)
1959             uzder(1,3,2)= dc_norm(2,i)
1960             uzder(2,3,2)=-dc_norm(1,i)
1961             uzder(3,3,2)= 0.0d0
1962 ! Compute the Y-axis
1963             facy=fac
1964             do k=1,3
1965               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1966             enddo
1967 ! Compute the derivatives of uy
1968             do j=1,3
1969               do k=1,3
1970                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
1971                               -dc_norm(k,i)*dc_norm(j,i-1)
1972                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1973               enddo
1974               uyder(j,j,1)=uyder(j,j,1)-costh
1975               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1976             enddo
1977             do j=1,2
1978               do k=1,3
1979                 do l=1,3
1980                   uygrad(l,k,j,i)=uyder(l,k,j)
1981                   uzgrad(l,k,j,i)=uzder(l,k,j)
1982                 enddo
1983               enddo
1984             enddo
1985             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1986             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1987             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1988             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1989           else
1990 ! Other residues
1991 ! Compute the Z-axis
1992             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1993             costh=dcos(pi-theta(i+2))
1994             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1995             do k=1,3
1996               uz(k,i)=fac*uz(k,i)
1997             enddo
1998 ! Compute the derivatives of uz
1999             uzder(1,1,1)= 0.0d0
2000             uzder(2,1,1)=-dc_norm(3,i+1)
2001             uzder(3,1,1)= dc_norm(2,i+1)
2002             uzder(1,2,1)= dc_norm(3,i+1)
2003             uzder(2,2,1)= 0.0d0
2004             uzder(3,2,1)=-dc_norm(1,i+1)
2005             uzder(1,3,1)=-dc_norm(2,i+1)
2006             uzder(2,3,1)= dc_norm(1,i+1)
2007             uzder(3,3,1)= 0.0d0
2008             uzder(1,1,2)= 0.0d0
2009             uzder(2,1,2)= dc_norm(3,i)
2010             uzder(3,1,2)=-dc_norm(2,i)
2011             uzder(1,2,2)=-dc_norm(3,i)
2012             uzder(2,2,2)= 0.0d0
2013             uzder(3,2,2)= dc_norm(1,i)
2014             uzder(1,3,2)= dc_norm(2,i)
2015             uzder(2,3,2)=-dc_norm(1,i)
2016             uzder(3,3,2)= 0.0d0
2017 ! Compute the Y-axis
2018             facy=fac
2019             do k=1,3
2020               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2021             enddo
2022 ! Compute the derivatives of uy
2023             do j=1,3
2024               do k=1,3
2025                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2026                               -dc_norm(k,i)*dc_norm(j,i+1)
2027                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2028               enddo
2029               uyder(j,j,1)=uyder(j,j,1)-costh
2030               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2031             enddo
2032             do j=1,2
2033               do k=1,3
2034                 do l=1,3
2035                   uygrad(l,k,j,i)=uyder(l,k,j)
2036                   uzgrad(l,k,j,i)=uzder(l,k,j)
2037                 enddo
2038               enddo
2039             enddo
2040             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2041             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2042             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2043             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2044           endif
2045       enddo
2046       do i=1,nres-1
2047         vbld_inv_temp(1)=vbld_inv(i+1)
2048         if (i.lt.nres-1) then
2049           vbld_inv_temp(2)=vbld_inv(i+2)
2050           else
2051           vbld_inv_temp(2)=vbld_inv(i)
2052           endif
2053         do j=1,2
2054           do k=1,3
2055             do l=1,3
2056               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2057               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2058             enddo
2059           enddo
2060         enddo
2061       enddo
2062 #if defined(PARVEC) && defined(MPI)
2063       if (nfgtasks1.gt.1) then
2064         time00=MPI_Wtime()
2065 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2066 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2067 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2068         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2069          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2070          FG_COMM1,IERR)
2071         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2072          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2073          FG_COMM1,IERR)
2074         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2075          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2076          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2077         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2078          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2079          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2080         time_gather=time_gather+MPI_Wtime()-time00
2081       endif
2082 !      if (fg_rank.eq.0) then
2083 !        write (iout,*) "Arrays UY and UZ"
2084 !        do i=1,nres-1
2085 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2086 !     &     (uz(k,i),k=1,3)
2087 !        enddo
2088 !      endif
2089 #endif
2090       return
2091       end subroutine vec_and_deriv
2092 !-----------------------------------------------------------------------------
2093       subroutine check_vecgrad
2094 !      implicit real*8 (a-h,o-z)
2095 !      include 'DIMENSIONS'
2096 !      include 'COMMON.IOUNITS'
2097 !      include 'COMMON.GEO'
2098 !      include 'COMMON.VAR'
2099 !      include 'COMMON.LOCAL'
2100 !      include 'COMMON.CHAIN'
2101 !      include 'COMMON.VECTORS'
2102       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt     !(3,3,2,maxres)
2103       real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
2104       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2105       real(kind=8),dimension(3) :: erij
2106       real(kind=8) :: delta=1.0d-7
2107 !el local variables
2108       integer :: i,j,k,l
2109
2110       call vec_and_deriv
2111 !d      do i=1,nres
2112 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2113 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2114 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2115 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2116 !d     &     (dc_norm(if90,i),if90=1,3)
2117 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2118 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2119 !d          write(iout,'(a)')
2120 !d      enddo
2121       do i=1,nres
2122         do j=1,2
2123           do k=1,3
2124             do l=1,3
2125               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2126               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2127             enddo
2128           enddo
2129         enddo
2130       enddo
2131       call vec_and_deriv
2132       do i=1,nres
2133         do j=1,3
2134           uyt(j,i)=uy(j,i)
2135           uzt(j,i)=uz(j,i)
2136         enddo
2137       enddo
2138       do i=1,nres
2139 !d        write (iout,*) 'i=',i
2140         do k=1,3
2141           erij(k)=dc_norm(k,i)
2142         enddo
2143         do j=1,3
2144           do k=1,3
2145             dc_norm(k,i)=erij(k)
2146           enddo
2147           dc_norm(j,i)=dc_norm(j,i)+delta
2148 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2149 !          do k=1,3
2150 !            dc_norm(k,i)=dc_norm(k,i)/fac
2151 !          enddo
2152 !          write (iout,*) (dc_norm(k,i),k=1,3)
2153 !          write (iout,*) (erij(k),k=1,3)
2154           call vec_and_deriv
2155           do k=1,3
2156             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2157             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2158             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2159             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2160           enddo
2161 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2162 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2163 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2164         enddo
2165         do k=1,3
2166           dc_norm(k,i)=erij(k)
2167         enddo
2168 !d        do k=1,3
2169 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2170 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2171 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2172 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2173 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2174 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2175 !d          write (iout,'(a)')
2176 !d        enddo
2177       enddo
2178       return
2179       end subroutine check_vecgrad
2180 !-----------------------------------------------------------------------------
2181       subroutine set_matrices
2182 !      implicit real*8 (a-h,o-z)
2183 !      include 'DIMENSIONS'
2184 #ifdef MPI
2185       include "mpif.h"
2186 !      include "COMMON.SETUP"
2187       integer :: IERR
2188       integer :: status(MPI_STATUS_SIZE)
2189 #endif
2190 !      include 'COMMON.IOUNITS'
2191 !      include 'COMMON.GEO'
2192 !      include 'COMMON.VAR'
2193 !      include 'COMMON.LOCAL'
2194 !      include 'COMMON.CHAIN'
2195 !      include 'COMMON.DERIV'
2196 !      include 'COMMON.INTERACT'
2197 !      include 'COMMON.CONTACTS'
2198 !      include 'COMMON.TORSION'
2199 !      include 'COMMON.VECTORS'
2200 !      include 'COMMON.FFIELD'
2201       real(kind=8) :: auxvec(2),auxmat(2,2)
2202       integer :: i,iti1,iti,k,l
2203       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2204 !       print *,"in set matrices"
2205 !
2206 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2207 ! to calculate the el-loc multibody terms of various order.
2208 !
2209 !AL el      mu=0.0d0
2210 #ifdef PARMAT
2211       do i=ivec_start+2,ivec_end+2
2212 #else
2213       do i=3,nres+1
2214 #endif
2215 !      print *,i,"i"
2216         if (i .lt. nres+1) then
2217           sin1=dsin(phi(i))
2218           cos1=dcos(phi(i))
2219           sintab(i-2)=sin1
2220           costab(i-2)=cos1
2221           obrot(1,i-2)=cos1
2222           obrot(2,i-2)=sin1
2223           sin2=dsin(2*phi(i))
2224           cos2=dcos(2*phi(i))
2225           sintab2(i-2)=sin2
2226           costab2(i-2)=cos2
2227           obrot2(1,i-2)=cos2
2228           obrot2(2,i-2)=sin2
2229           Ug(1,1,i-2)=-cos1
2230           Ug(1,2,i-2)=-sin1
2231           Ug(2,1,i-2)=-sin1
2232           Ug(2,2,i-2)= cos1
2233           Ug2(1,1,i-2)=-cos2
2234           Ug2(1,2,i-2)=-sin2
2235           Ug2(2,1,i-2)=-sin2
2236           Ug2(2,2,i-2)= cos2
2237         else
2238           costab(i-2)=1.0d0
2239           sintab(i-2)=0.0d0
2240           obrot(1,i-2)=1.0d0
2241           obrot(2,i-2)=0.0d0
2242           obrot2(1,i-2)=0.0d0
2243           obrot2(2,i-2)=0.0d0
2244           Ug(1,1,i-2)=1.0d0
2245           Ug(1,2,i-2)=0.0d0
2246           Ug(2,1,i-2)=0.0d0
2247           Ug(2,2,i-2)=1.0d0
2248           Ug2(1,1,i-2)=0.0d0
2249           Ug2(1,2,i-2)=0.0d0
2250           Ug2(2,1,i-2)=0.0d0
2251           Ug2(2,2,i-2)=0.0d0
2252         endif
2253         if (i .gt. 3 .and. i .lt. nres+1) then
2254           obrot_der(1,i-2)=-sin1
2255           obrot_der(2,i-2)= cos1
2256           Ugder(1,1,i-2)= sin1
2257           Ugder(1,2,i-2)=-cos1
2258           Ugder(2,1,i-2)=-cos1
2259           Ugder(2,2,i-2)=-sin1
2260           dwacos2=cos2+cos2
2261           dwasin2=sin2+sin2
2262           obrot2_der(1,i-2)=-dwasin2
2263           obrot2_der(2,i-2)= dwacos2
2264           Ug2der(1,1,i-2)= dwasin2
2265           Ug2der(1,2,i-2)=-dwacos2
2266           Ug2der(2,1,i-2)=-dwacos2
2267           Ug2der(2,2,i-2)=-dwasin2
2268         else
2269           obrot_der(1,i-2)=0.0d0
2270           obrot_der(2,i-2)=0.0d0
2271           Ugder(1,1,i-2)=0.0d0
2272           Ugder(1,2,i-2)=0.0d0
2273           Ugder(2,1,i-2)=0.0d0
2274           Ugder(2,2,i-2)=0.0d0
2275           obrot2_der(1,i-2)=0.0d0
2276           obrot2_der(2,i-2)=0.0d0
2277           Ug2der(1,1,i-2)=0.0d0
2278           Ug2der(1,2,i-2)=0.0d0
2279           Ug2der(2,1,i-2)=0.0d0
2280           Ug2der(2,2,i-2)=0.0d0
2281         endif
2282 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2283         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2284           iti = itortyp(itype(i-2))
2285         else
2286           iti=ntortyp+1
2287         endif
2288 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2289         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2290           iti1 = itortyp(itype(i-1))
2291         else
2292           iti1=ntortyp+1
2293         endif
2294 !          print *,iti,i,"iti",iti1,itype(i-1),itype(i-2)
2295 !d        write (iout,*) '*******i',i,' iti1',iti
2296 !d        write (iout,*) 'b1',b1(:,iti)
2297 !d        write (iout,*) 'b2',b2(:,iti)
2298 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2299 !        if (i .gt. iatel_s+2) then
2300         if (i .gt. nnt+2) then
2301           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2302           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2303           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2304           then
2305           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2306           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2307           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2308           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2309           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2310           endif
2311         else
2312           do k=1,2
2313             Ub2(k,i-2)=0.0d0
2314             Ctobr(k,i-2)=0.0d0
2315             Dtobr2(k,i-2)=0.0d0
2316             do l=1,2
2317               EUg(l,k,i-2)=0.0d0
2318               CUg(l,k,i-2)=0.0d0
2319               DUg(l,k,i-2)=0.0d0
2320               DtUg2(l,k,i-2)=0.0d0
2321             enddo
2322           enddo
2323         endif
2324         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2325         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2326         do k=1,2
2327           muder(k,i-2)=Ub2der(k,i-2)
2328         enddo
2329 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2330         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2331           if (itype(i-1).le.ntyp) then
2332             iti1 = itortyp(itype(i-1))
2333           else
2334             iti1=ntortyp+1
2335           endif
2336         else
2337           iti1=ntortyp+1
2338         endif
2339         do k=1,2
2340           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2341         enddo
2342 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2343 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2344 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2345 !d        write (iout,*) 'mu1',mu1(:,i-2)
2346 !d        write (iout,*) 'mu2',mu2(:,i-2)
2347         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2348         then
2349         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2350         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2351         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2352         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2353         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2354 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2355         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2356         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2357         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2358         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2359         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2360         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2361         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2362         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2363         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2364         endif
2365       enddo
2366 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2367 ! The order of matrices is from left to right.
2368       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2369       then
2370 !      do i=max0(ivec_start,2),ivec_end
2371       do i=2,nres-1
2372         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2373         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2374         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2375         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2376         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2377         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2378         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2379         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2380       enddo
2381       endif
2382 #if defined(MPI) && defined(PARMAT)
2383 #ifdef DEBUG
2384 !      if (fg_rank.eq.0) then
2385         write (iout,*) "Arrays UG and UGDER before GATHER"
2386         do i=1,nres-1
2387           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2388            ((ug(l,k,i),l=1,2),k=1,2),&
2389            ((ugder(l,k,i),l=1,2),k=1,2)
2390         enddo
2391         write (iout,*) "Arrays UG2 and UG2DER"
2392         do i=1,nres-1
2393           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2394            ((ug2(l,k,i),l=1,2),k=1,2),&
2395            ((ug2der(l,k,i),l=1,2),k=1,2)
2396         enddo
2397         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2398         do i=1,nres-1
2399           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2400            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2401            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2402         enddo
2403         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2404         do i=1,nres-1
2405           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2406            costab(i),sintab(i),costab2(i),sintab2(i)
2407         enddo
2408         write (iout,*) "Array MUDER"
2409         do i=1,nres-1
2410           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2411         enddo
2412 !      endif
2413 #endif
2414       if (nfgtasks.gt.1) then
2415         time00=MPI_Wtime()
2416 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2417 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2418 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2419 #ifdef MATGATHER
2420         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2421          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2422          FG_COMM1,IERR)
2423         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2424          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2425          FG_COMM1,IERR)
2426         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2427          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2428          FG_COMM1,IERR)
2429         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2430          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2431          FG_COMM1,IERR)
2432         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2433          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2434          FG_COMM1,IERR)
2435         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2436          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2437          FG_COMM1,IERR)
2438         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2439          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2440          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2441         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2442          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2443          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2444         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2445          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2446          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2447         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2448          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2449          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2450         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2451         then
2452         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2453          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2454          FG_COMM1,IERR)
2455         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2456          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2457          FG_COMM1,IERR)
2458         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2459          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2460          FG_COMM1,IERR)
2461        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2462          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2463          FG_COMM1,IERR)
2464         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2465          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2466          FG_COMM1,IERR)
2467         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2468          ivec_count(fg_rank1),&
2469          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2470          FG_COMM1,IERR)
2471         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2472          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2473          FG_COMM1,IERR)
2474         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2475          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2476          FG_COMM1,IERR)
2477         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2478          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2479          FG_COMM1,IERR)
2480         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2481          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2482          FG_COMM1,IERR)
2483         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2484          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2485          FG_COMM1,IERR)
2486         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2487          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2488          FG_COMM1,IERR)
2489         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2490          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2491          FG_COMM1,IERR)
2492         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2493          ivec_count(fg_rank1),&
2494          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2495          FG_COMM1,IERR)
2496         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2497          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2498          FG_COMM1,IERR)
2499        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2500          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2501          FG_COMM1,IERR)
2502         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2503          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2504          FG_COMM1,IERR)
2505        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2506          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2507          FG_COMM1,IERR)
2508         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2509          ivec_count(fg_rank1),&
2510          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2511          FG_COMM1,IERR)
2512         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2513          ivec_count(fg_rank1),&
2514          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2515          FG_COMM1,IERR)
2516         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2517          ivec_count(fg_rank1),&
2518          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2519          MPI_MAT2,FG_COMM1,IERR)
2520         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2521          ivec_count(fg_rank1),&
2522          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2523          MPI_MAT2,FG_COMM1,IERR)
2524         endif
2525 #else
2526 ! Passes matrix info through the ring
2527       isend=fg_rank1
2528       irecv=fg_rank1-1
2529       if (irecv.lt.0) irecv=nfgtasks1-1
2530       iprev=irecv
2531       inext=fg_rank1+1
2532       if (inext.ge.nfgtasks1) inext=0
2533       do i=1,nfgtasks1-1
2534 !        write (iout,*) "isend",isend," irecv",irecv
2535 !        call flush(iout)
2536         lensend=lentyp(isend)
2537         lenrecv=lentyp(irecv)
2538 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2539 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2540 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2541 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2542 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2543 !        write (iout,*) "Gather ROTAT1"
2544 !        call flush(iout)
2545 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2546 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2547 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2548 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2549 !        write (iout,*) "Gather ROTAT2"
2550 !        call flush(iout)
2551         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2552          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2553          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2554          iprev,4400+irecv,FG_COMM,status,IERR)
2555 !        write (iout,*) "Gather ROTAT_OLD"
2556 !        call flush(iout)
2557         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2558          MPI_PRECOMP11(lensend),inext,5500+isend,&
2559          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2560          iprev,5500+irecv,FG_COMM,status,IERR)
2561 !        write (iout,*) "Gather PRECOMP11"
2562 !        call flush(iout)
2563         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2564          MPI_PRECOMP12(lensend),inext,6600+isend,&
2565          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2566          iprev,6600+irecv,FG_COMM,status,IERR)
2567 !        write (iout,*) "Gather PRECOMP12"
2568 !        call flush(iout)
2569         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2570         then
2571         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2572          MPI_ROTAT2(lensend),inext,7700+isend,&
2573          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2574          iprev,7700+irecv,FG_COMM,status,IERR)
2575 !        write (iout,*) "Gather PRECOMP21"
2576 !        call flush(iout)
2577         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2578          MPI_PRECOMP22(lensend),inext,8800+isend,&
2579          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2580          iprev,8800+irecv,FG_COMM,status,IERR)
2581 !        write (iout,*) "Gather PRECOMP22"
2582 !        call flush(iout)
2583         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2584          MPI_PRECOMP23(lensend),inext,9900+isend,&
2585          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2586          MPI_PRECOMP23(lenrecv),&
2587          iprev,9900+irecv,FG_COMM,status,IERR)
2588 !        write (iout,*) "Gather PRECOMP23"
2589 !        call flush(iout)
2590         endif
2591         isend=irecv
2592         irecv=irecv-1
2593         if (irecv.lt.0) irecv=nfgtasks1-1
2594       enddo
2595 #endif
2596         time_gather=time_gather+MPI_Wtime()-time00
2597       endif
2598 #ifdef DEBUG
2599 !      if (fg_rank.eq.0) then
2600         write (iout,*) "Arrays UG and UGDER"
2601         do i=1,nres-1
2602           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2603            ((ug(l,k,i),l=1,2),k=1,2),&
2604            ((ugder(l,k,i),l=1,2),k=1,2)
2605         enddo
2606         write (iout,*) "Arrays UG2 and UG2DER"
2607         do i=1,nres-1
2608           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2609            ((ug2(l,k,i),l=1,2),k=1,2),&
2610            ((ug2der(l,k,i),l=1,2),k=1,2)
2611         enddo
2612         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2613         do i=1,nres-1
2614           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2615            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2616            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2617         enddo
2618         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2619         do i=1,nres-1
2620           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2621            costab(i),sintab(i),costab2(i),sintab2(i)
2622         enddo
2623         write (iout,*) "Array MUDER"
2624         do i=1,nres-1
2625           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2626         enddo
2627 !      endif
2628 #endif
2629 #endif
2630 !d      do i=1,nres
2631 !d        iti = itortyp(itype(i))
2632 !d        write (iout,*) i
2633 !d        do j=1,2
2634 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2635 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2636 !d        enddo
2637 !d      enddo
2638       return
2639       end subroutine set_matrices
2640 !-----------------------------------------------------------------------------
2641       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2642 !
2643 ! This subroutine calculates the average interaction energy and its gradient
2644 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2645 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2646 ! The potential depends both on the distance of peptide-group centers and on
2647 ! the orientation of the CA-CA virtual bonds.
2648 !
2649       use comm_locel
2650 !      implicit real*8 (a-h,o-z)
2651 #ifdef MPI
2652       include 'mpif.h'
2653 #endif
2654 !      include 'DIMENSIONS'
2655 !      include 'COMMON.CONTROL'
2656 !      include 'COMMON.SETUP'
2657 !      include 'COMMON.IOUNITS'
2658 !      include 'COMMON.GEO'
2659 !      include 'COMMON.VAR'
2660 !      include 'COMMON.LOCAL'
2661 !      include 'COMMON.CHAIN'
2662 !      include 'COMMON.DERIV'
2663 !      include 'COMMON.INTERACT'
2664 !      include 'COMMON.CONTACTS'
2665 !      include 'COMMON.TORSION'
2666 !      include 'COMMON.VECTORS'
2667 !      include 'COMMON.FFIELD'
2668 !      include 'COMMON.TIME1'
2669       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2670       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2671       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2672 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2673       real(kind=8),dimension(4) :: muij
2674 !el      integer :: num_conti,j1,j2
2675 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2676 !el        dz_normi,xmedi,ymedi,zmedi
2677
2678 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2679 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2680 !el          num_conti,j1,j2
2681
2682 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2683 #ifdef MOMENT
2684       real(kind=8) :: scal_el=1.0d0
2685 #else
2686       real(kind=8) :: scal_el=0.5d0
2687 #endif
2688 ! 12/13/98
2689 ! 13-go grudnia roku pamietnego...
2690       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2691                                              0.0d0,1.0d0,0.0d0,&
2692                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2693 !el local variables
2694       integer :: i,k,j
2695       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2696       real(kind=8) :: fac,t_eelecij,fracinbuf
2697
2698
2699 !d      write(iout,*) 'In EELEC'
2700         print *,"IN EELEC"
2701 !d      do i=1,nloctyp
2702 !d        write(iout,*) 'Type',i
2703 !d        write(iout,*) 'B1',B1(:,i)
2704 !d        write(iout,*) 'B2',B2(:,i)
2705 !d        write(iout,*) 'CC',CC(:,:,i)
2706 !d        write(iout,*) 'DD',DD(:,:,i)
2707 !d        write(iout,*) 'EE',EE(:,:,i)
2708 !d      enddo
2709 !d      call check_vecgrad
2710 !d      stop
2711 !      ees=0.0d0  !AS
2712 !      evdw1=0.0d0
2713 !      eel_loc=0.0d0
2714 !      eello_turn3=0.0d0
2715 !      eello_turn4=0.0d0
2716       t_eelecij=0.0d0
2717       ees=0.0D0
2718       evdw1=0.0D0
2719       eel_loc=0.0d0
2720       eello_turn3=0.0d0
2721       eello_turn4=0.0d0
2722 !
2723
2724       if (icheckgrad.eq.1) then
2725 !el
2726 !        do i=0,2*nres+2
2727 !          dc_norm(1,i)=0.0d0
2728 !          dc_norm(2,i)=0.0d0
2729 !          dc_norm(3,i)=0.0d0
2730 !        enddo
2731         do i=1,nres-1
2732           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2733           do k=1,3
2734             dc_norm(k,i)=dc(k,i)*fac
2735           enddo
2736 !          write (iout,*) 'i',i,' fac',fac
2737         enddo
2738       endif
2739       print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
2740         wturn6
2741       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2742           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2743           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2744 !        call vec_and_deriv
2745 #ifdef TIMING
2746         time01=MPI_Wtime()
2747 #endif
2748 !        print *, "before set matrices"
2749         call set_matrices
2750 !        print *, "after set matrices"
2751
2752 #ifdef TIMING
2753         time_mat=time_mat+MPI_Wtime()-time01
2754 #endif
2755       endif
2756        print *, "after set matrices"
2757 !d      do i=1,nres-1
2758 !d        write (iout,*) 'i=',i
2759 !d        do k=1,3
2760 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2761 !d        enddo
2762 !d        do k=1,3
2763 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2764 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2765 !d        enddo
2766 !d      enddo
2767       t_eelecij=0.0d0
2768       ees=0.0D0
2769       evdw1=0.0D0
2770       eel_loc=0.0d0
2771       eello_turn3=0.0d0
2772       eello_turn4=0.0d0
2773 !el      ind=0
2774       do i=1,nres
2775         num_cont_hb(i)=0
2776       enddo
2777 !d      print '(a)','Enter EELEC'
2778 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2779 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2780 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2781       do i=1,nres
2782         gel_loc_loc(i)=0.0d0
2783         gcorr_loc(i)=0.0d0
2784       enddo
2785 !
2786 !
2787 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2788 !
2789 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
2790 !
2791
2792
2793         print *,"before iturn3 loop"
2794       do i=iturn3_start,iturn3_end
2795         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2796         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2797         dxi=dc(1,i)
2798         dyi=dc(2,i)
2799         dzi=dc(3,i)
2800         dx_normi=dc_norm(1,i)
2801         dy_normi=dc_norm(2,i)
2802         dz_normi=dc_norm(3,i)
2803         xmedi=c(1,i)+0.5d0*dxi
2804         ymedi=c(2,i)+0.5d0*dyi
2805         zmedi=c(3,i)+0.5d0*dzi
2806           xmedi=dmod(xmedi,boxxsize)
2807           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2808           ymedi=dmod(ymedi,boxysize)
2809           if (ymedi.lt.0) ymedi=ymedi+boxysize
2810           zmedi=dmod(zmedi,boxzsize)
2811           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2812         num_conti=0
2813        if ((zmedi.gt.bordlipbot) &
2814         .and.(zmedi.lt.bordliptop)) then
2815 !C the energy transfer exist
2816         if (zmedi.lt.buflipbot) then
2817 !C what fraction I am in
2818          fracinbuf=1.0d0- &
2819                ((zmedi-bordlipbot)/lipbufthick)
2820 !C lipbufthick is thickenes of lipid buffore
2821          sslipi=sscalelip(fracinbuf)
2822          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2823         elseif (zmedi.gt.bufliptop) then
2824          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2825          sslipi=sscalelip(fracinbuf)
2826          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2827         else
2828          sslipi=1.0d0
2829          ssgradlipi=0.0
2830         endif
2831        else
2832          sslipi=0.0d0
2833          ssgradlipi=0.0
2834        endif
2835        print *,i,sslipi,ssgradlipi
2836        call eelecij(i,i+2,ees,evdw1,eel_loc)
2837         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2838         num_cont_hb(i)=num_conti
2839       enddo
2840       do i=iturn4_start,iturn4_end
2841         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
2842           .or. itype(i+3).eq.ntyp1 &
2843           .or. itype(i+4).eq.ntyp1) cycle
2844         dxi=dc(1,i)
2845         dyi=dc(2,i)
2846         dzi=dc(3,i)
2847         dx_normi=dc_norm(1,i)
2848         dy_normi=dc_norm(2,i)
2849         dz_normi=dc_norm(3,i)
2850         xmedi=c(1,i)+0.5d0*dxi
2851         ymedi=c(2,i)+0.5d0*dyi
2852         zmedi=c(3,i)+0.5d0*dzi
2853           xmedi=dmod(xmedi,boxxsize)
2854           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2855           ymedi=dmod(ymedi,boxysize)
2856           if (ymedi.lt.0) ymedi=ymedi+boxysize
2857           zmedi=dmod(zmedi,boxzsize)
2858           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2859        if ((zmedi.gt.bordlipbot)  &
2860        .and.(zmedi.lt.bordliptop)) then
2861 !C the energy transfer exist
2862         if (zmedi.lt.buflipbot) then
2863 !C what fraction I am in
2864          fracinbuf=1.0d0- &
2865              ((zmedi-bordlipbot)/lipbufthick)
2866 !C lipbufthick is thickenes of lipid buffore
2867          sslipi=sscalelip(fracinbuf)
2868          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2869         elseif (zmedi.gt.bufliptop) then
2870          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2871          sslipi=sscalelip(fracinbuf)
2872          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2873         else
2874          sslipi=1.0d0
2875          ssgradlipi=0.0
2876         endif
2877        else
2878          sslipi=0.0d0
2879          ssgradlipi=0.0
2880        endif
2881
2882         num_conti=num_cont_hb(i)
2883         call eelecij(i,i+3,ees,evdw1,eel_loc)
2884         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
2885          call eturn4(i,eello_turn4)
2886         num_cont_hb(i)=num_conti
2887       enddo   ! i
2888 !
2889 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2890 !
2891       do i=iatel_s,iatel_e
2892         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2893         dxi=dc(1,i)
2894         dyi=dc(2,i)
2895         dzi=dc(3,i)
2896         dx_normi=dc_norm(1,i)
2897         dy_normi=dc_norm(2,i)
2898         dz_normi=dc_norm(3,i)
2899         xmedi=c(1,i)+0.5d0*dxi
2900         ymedi=c(2,i)+0.5d0*dyi
2901         zmedi=c(3,i)+0.5d0*dzi
2902           xmedi=dmod(xmedi,boxxsize)
2903           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2904           ymedi=dmod(ymedi,boxysize)
2905           if (ymedi.lt.0) ymedi=ymedi+boxysize
2906           zmedi=dmod(zmedi,boxzsize)
2907           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2908        if ((zmedi.gt.bordlipbot)  &
2909         .and.(zmedi.lt.bordliptop)) then
2910 !C the energy transfer exist
2911         if (zmedi.lt.buflipbot) then
2912 !C what fraction I am in
2913          fracinbuf=1.0d0- &
2914              ((zmedi-bordlipbot)/lipbufthick)
2915 !C lipbufthick is thickenes of lipid buffore
2916          sslipi=sscalelip(fracinbuf)
2917          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2918         elseif (zmedi.gt.bufliptop) then
2919          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2920          sslipi=sscalelip(fracinbuf)
2921          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2922         else
2923          sslipi=1.0d0
2924          ssgradlipi=0.0
2925         endif
2926        else
2927          sslipi=0.0d0
2928          ssgradlipi=0.0
2929        endif
2930
2931 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2932         num_conti=num_cont_hb(i)
2933         do j=ielstart(i),ielend(i)
2934 !          write (iout,*) i,j,itype(i),itype(j)
2935           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2936           call eelecij(i,j,ees,evdw1,eel_loc)
2937         enddo ! j
2938         num_cont_hb(i)=num_conti
2939       enddo   ! i
2940 !      write (iout,*) "Number of loop steps in EELEC:",ind
2941 !d      do i=1,nres
2942 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
2943 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2944 !d      enddo
2945 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2946 !cc      eel_loc=eel_loc+eello_turn3
2947 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2948       return
2949       end subroutine eelec
2950 !-----------------------------------------------------------------------------
2951       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2952
2953       use comm_locel
2954 !      implicit real*8 (a-h,o-z)
2955 !      include 'DIMENSIONS'
2956 #ifdef MPI
2957       include "mpif.h"
2958 #endif
2959 !      include 'COMMON.CONTROL'
2960 !      include 'COMMON.IOUNITS'
2961 !      include 'COMMON.GEO'
2962 !      include 'COMMON.VAR'
2963 !      include 'COMMON.LOCAL'
2964 !      include 'COMMON.CHAIN'
2965 !      include 'COMMON.DERIV'
2966 !      include 'COMMON.INTERACT'
2967 !      include 'COMMON.CONTACTS'
2968 !      include 'COMMON.TORSION'
2969 !      include 'COMMON.VECTORS'
2970 !      include 'COMMON.FFIELD'
2971 !      include 'COMMON.TIME1'
2972       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
2973       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2974       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2975 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2976       real(kind=8),dimension(4) :: muij
2977       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
2978                     dist_temp, dist_init,rlocshield,fracinbuf
2979       integer xshift,yshift,zshift,ilist,iresshield
2980 !el      integer :: num_conti,j1,j2
2981 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2982 !el        dz_normi,xmedi,ymedi,zmedi
2983
2984 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2985 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2986 !el          num_conti,j1,j2
2987
2988 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2989 #ifdef MOMENT
2990       real(kind=8) :: scal_el=1.0d0
2991 #else
2992       real(kind=8) :: scal_el=0.5d0
2993 #endif
2994 ! 12/13/98
2995 ! 13-go grudnia roku pamietnego...
2996       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2997                                              0.0d0,1.0d0,0.0d0,&
2998                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2999 !      integer :: maxconts=nres/4
3000 !el local variables
3001       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3002       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3003       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3004       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3005                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3006                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3007                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3008                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3009                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3010                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3011                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3012 !      maxconts=nres/4
3013 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3014 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3015
3016 !          time00=MPI_Wtime()
3017 !d      write (iout,*) "eelecij",i,j
3018 !          ind=ind+1
3019           iteli=itel(i)
3020           itelj=itel(j)
3021           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3022           aaa=app(iteli,itelj)
3023           bbb=bpp(iteli,itelj)
3024           ael6i=ael6(iteli,itelj)
3025           ael3i=ael3(iteli,itelj)
3026           dxj=dc(1,j)
3027           dyj=dc(2,j)
3028           dzj=dc(3,j)
3029           dx_normj=dc_norm(1,j)
3030           dy_normj=dc_norm(2,j)
3031           dz_normj=dc_norm(3,j)
3032 !          xj=c(1,j)+0.5D0*dxj-xmedi
3033 !          yj=c(2,j)+0.5D0*dyj-ymedi
3034 !          zj=c(3,j)+0.5D0*dzj-zmedi
3035           xj=c(1,j)+0.5D0*dxj
3036           yj=c(2,j)+0.5D0*dyj
3037           zj=c(3,j)+0.5D0*dzj
3038           xj=mod(xj,boxxsize)
3039           if (xj.lt.0) xj=xj+boxxsize
3040           yj=mod(yj,boxysize)
3041           if (yj.lt.0) yj=yj+boxysize
3042           zj=mod(zj,boxzsize)
3043           if (zj.lt.0) zj=zj+boxzsize
3044        if ((zj.gt.bordlipbot)  &
3045        .and.(zj.lt.bordliptop)) then
3046 !C the energy transfer exist
3047         if (zj.lt.buflipbot) then
3048 !C what fraction I am in
3049          fracinbuf=1.0d0-     &
3050              ((zj-bordlipbot)/lipbufthick)
3051 !C lipbufthick is thickenes of lipid buffore
3052          sslipj=sscalelip(fracinbuf)
3053          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3054         elseif (zj.gt.bufliptop) then
3055          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3056          sslipj=sscalelip(fracinbuf)
3057          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3058         else
3059          sslipj=1.0d0
3060          ssgradlipj=0.0
3061         endif
3062        else
3063          sslipj=0.0d0
3064          ssgradlipj=0.0
3065        endif
3066
3067       isubchap=0
3068       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3069       xj_safe=xj
3070       yj_safe=yj
3071       zj_safe=zj
3072       do xshift=-1,1
3073       do yshift=-1,1
3074       do zshift=-1,1
3075           xj=xj_safe+xshift*boxxsize
3076           yj=yj_safe+yshift*boxysize
3077           zj=zj_safe+zshift*boxzsize
3078           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3079           if(dist_temp.lt.dist_init) then
3080             dist_init=dist_temp
3081             xj_temp=xj
3082             yj_temp=yj
3083             zj_temp=zj
3084             isubchap=1
3085           endif
3086        enddo
3087        enddo
3088        enddo
3089        if (isubchap.eq.1) then
3090 !C          print *,i,j
3091           xj=xj_temp-xmedi
3092           yj=yj_temp-ymedi
3093           zj=zj_temp-zmedi
3094        else
3095           xj=xj_safe-xmedi
3096           yj=yj_safe-ymedi
3097           zj=zj_safe-zmedi
3098        endif
3099
3100           rij=xj*xj+yj*yj+zj*zj
3101           rrmij=1.0D0/rij
3102           rij=dsqrt(rij)
3103 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3104             sss_ele_cut=sscale_ele(rij)
3105             sss_ele_grad=sscagrad_ele(rij)
3106 !             sss_ele_cut=1.0d0
3107 !             sss_ele_grad=0.0d0
3108 !            print *,sss_ele_cut,sss_ele_grad,&
3109 !            (rij),r_cut_ele,rlamb_ele
3110 !            if (sss_ele_cut.le.0.0) go to 128
3111
3112           rmij=1.0D0/rij
3113           r3ij=rrmij*rmij
3114           r6ij=r3ij*r3ij
3115           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3116           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3117           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3118           fac=cosa-3.0D0*cosb*cosg
3119           ev1=aaa*r6ij*r6ij
3120 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3121           if (j.eq.i+2) ev1=scal_el*ev1
3122           ev2=bbb*r6ij
3123           fac3=ael6i*r6ij
3124           fac4=ael3i*r3ij
3125           evdwij=ev1+ev2
3126           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3127           el2=fac4*fac
3128 !          eesij=el1+el2
3129           if (shield_mode.gt.0) then
3130 !C          fac_shield(i)=0.4
3131 !C          fac_shield(j)=0.6
3132           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3133           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3134           eesij=(el1+el2)
3135           ees=ees+eesij*sss_ele_cut
3136 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3137 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3138           else
3139           fac_shield(i)=1.0
3140           fac_shield(j)=1.0
3141           eesij=(el1+el2)
3142           ees=ees+eesij   &
3143             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3144 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3145           endif
3146
3147 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3148           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3149 !          ees=ees+eesij*sss_ele_cut
3150           evdw1=evdw1+evdwij*sss_ele_cut  &
3151            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3152 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3153 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3154 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3155 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3156
3157           if (energy_dec) then
3158 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3159 !                  'evdw1',i,j,evdwij,&
3160 !                  iteli,itelj,aaa,evdw1
3161               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3162               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3163           endif
3164 !
3165 ! Calculate contributions to the Cartesian gradient.
3166 !
3167 #ifdef SPLITELE
3168           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3169               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3170           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3171              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3172           fac1=fac
3173           erij(1)=xj*rmij
3174           erij(2)=yj*rmij
3175           erij(3)=zj*rmij
3176 !
3177 ! Radial derivatives. First process both termini of the fragment (i,j)
3178 !
3179           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
3180           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
3181           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
3182
3183           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3184           (shield_mode.gt.0)) then
3185 !C          print *,i,j
3186           do ilist=1,ishield_list(i)
3187            iresshield=shield_list(ilist,i)
3188            do k=1,3
3189            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3190            *2.0*sss_ele_cut
3191            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3192                    rlocshield &
3193             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3194             *sss_ele_cut
3195             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3196            enddo
3197           enddo
3198           do ilist=1,ishield_list(j)
3199            iresshield=shield_list(ilist,j)
3200            do k=1,3
3201            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3202           *2.0*sss_ele_cut
3203            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3204                    rlocshield &
3205            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3206            *sss_ele_cut
3207            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3208            enddo
3209           enddo
3210           do k=1,3
3211             gshieldc(k,i)=gshieldc(k,i)+ &
3212                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3213            *sss_ele_cut
3214
3215             gshieldc(k,j)=gshieldc(k,j)+ &
3216                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3217            *sss_ele_cut
3218
3219             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3220                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3221            *sss_ele_cut
3222
3223             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3224                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3225            *sss_ele_cut
3226
3227            enddo
3228            endif
3229
3230
3231 !          do k=1,3
3232 !            ghalf=0.5D0*ggg(k)
3233 !            gelc(k,i)=gelc(k,i)+ghalf
3234 !            gelc(k,j)=gelc(k,j)+ghalf
3235 !          enddo
3236 ! 9/28/08 AL Gradient compotents will be summed only at the end
3237           do k=1,3
3238             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3239             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3240           enddo
3241             gelc_long(3,j)=gelc_long(3,j)+  &
3242           ssgradlipj*eesij/2.0d0*lipscale**2&
3243            *sss_ele_cut
3244
3245             gelc_long(3,i)=gelc_long(3,i)+  &
3246           ssgradlipi*eesij/2.0d0*lipscale**2&
3247            *sss_ele_cut
3248
3249
3250 !
3251 ! Loop over residues i+1 thru j-1.
3252 !
3253 !grad          do k=i+1,j-1
3254 !grad            do l=1,3
3255 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3256 !grad            enddo
3257 !grad          enddo
3258           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3259            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3260           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3261            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3262           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3263            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3264
3265 !          do k=1,3
3266 !            ghalf=0.5D0*ggg(k)
3267 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3268 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3269 !          enddo
3270 ! 9/28/08 AL Gradient compotents will be summed only at the end
3271           do k=1,3
3272             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3273             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3274           enddo
3275
3276 !C Lipidic part for scaling weight
3277            gvdwpp(3,j)=gvdwpp(3,j)+ &
3278           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3279            gvdwpp(3,i)=gvdwpp(3,i)+ &
3280           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3281 !! Loop over residues i+1 thru j-1.
3282 !
3283 !grad          do k=i+1,j-1
3284 !grad            do l=1,3
3285 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3286 !grad            enddo
3287 !grad          enddo
3288 #else
3289           facvdw=(ev1+evdwij)*sss_ele_cut &
3290            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3291
3292           facel=(el1+eesij)*sss_ele_cut
3293           fac1=fac
3294           fac=-3*rrmij*(facvdw+facvdw+facel)
3295           erij(1)=xj*rmij
3296           erij(2)=yj*rmij
3297           erij(3)=zj*rmij
3298 !
3299 ! Radial derivatives. First process both termini of the fragment (i,j)
3300 !
3301           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3302           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3303           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3304 !          do k=1,3
3305 !            ghalf=0.5D0*ggg(k)
3306 !            gelc(k,i)=gelc(k,i)+ghalf
3307 !            gelc(k,j)=gelc(k,j)+ghalf
3308 !          enddo
3309 ! 9/28/08 AL Gradient compotents will be summed only at the end
3310           do k=1,3
3311             gelc_long(k,j)=gelc(k,j)+ggg(k)
3312             gelc_long(k,i)=gelc(k,i)-ggg(k)
3313           enddo
3314 !
3315 ! Loop over residues i+1 thru j-1.
3316 !
3317 !grad          do k=i+1,j-1
3318 !grad            do l=1,3
3319 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3320 !grad            enddo
3321 !grad          enddo
3322 ! 9/28/08 AL Gradient compotents will be summed only at the end
3323           ggg(1)=facvdw*xj &
3324            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3325           ggg(2)=facvdw*yj &
3326            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3327           ggg(3)=facvdw*zj &
3328            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3329
3330           do k=1,3
3331             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3332             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3333           enddo
3334            gvdwpp(3,j)=gvdwpp(3,j)+ &
3335           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3336            gvdwpp(3,i)=gvdwpp(3,i)+ &
3337           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3338
3339 #endif
3340 !
3341 ! Angular part
3342 !
3343           ecosa=2.0D0*fac3*fac1+fac4
3344           fac4=-3.0D0*fac4
3345           fac3=-6.0D0*fac3
3346           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3347           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3348           do k=1,3
3349             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3350             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3351           enddo
3352 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3353 !d   &          (dcosg(k),k=1,3)
3354           do k=1,3
3355             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3356              *fac_shield(i)**2*fac_shield(j)**2 &
3357              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3358
3359           enddo
3360 !          do k=1,3
3361 !            ghalf=0.5D0*ggg(k)
3362 !            gelc(k,i)=gelc(k,i)+ghalf
3363 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3364 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3365 !            gelc(k,j)=gelc(k,j)+ghalf
3366 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3367 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3368 !          enddo
3369 !grad          do k=i+1,j-1
3370 !grad            do l=1,3
3371 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3372 !grad            enddo
3373 !grad          enddo
3374           do k=1,3
3375             gelc(k,i)=gelc(k,i) &
3376                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3377                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3378                      *sss_ele_cut &
3379                      *fac_shield(i)**2*fac_shield(j)**2 &
3380                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3381
3382             gelc(k,j)=gelc(k,j) &
3383                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3384                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3385                      *sss_ele_cut  &
3386                      *fac_shield(i)**2*fac_shield(j)**2  &
3387                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3388
3389             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3390             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3391           enddo
3392
3393           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3394               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3395               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3396 !
3397 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3398 !   energy of a peptide unit is assumed in the form of a second-order
3399 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3400 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3401 !   are computed for EVERY pair of non-contiguous peptide groups.
3402 !
3403           if (j.lt.nres-1) then
3404             j1=j+1
3405             j2=j-1
3406           else
3407             j1=j-1
3408             j2=j-2
3409           endif
3410           kkk=0
3411           do k=1,2
3412             do l=1,2
3413               kkk=kkk+1
3414               muij(kkk)=mu(k,i)*mu(l,j)
3415             enddo
3416           enddo
3417 !d         write (iout,*) 'EELEC: i',i,' j',j
3418 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3419 !d          write(iout,*) 'muij',muij
3420           ury=scalar(uy(1,i),erij)
3421           urz=scalar(uz(1,i),erij)
3422           vry=scalar(uy(1,j),erij)
3423           vrz=scalar(uz(1,j),erij)
3424           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3425           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3426           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3427           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3428           fac=dsqrt(-ael6i)*r3ij
3429           a22=a22*fac
3430           a23=a23*fac
3431           a32=a32*fac
3432           a33=a33*fac
3433 !d          write (iout,'(4i5,4f10.5)')
3434 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3435 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3436 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3437 !d     &      uy(:,j),uz(:,j)
3438 !d          write (iout,'(4f10.5)')
3439 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3440 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3441 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3442 !d           write (iout,'(9f10.5/)')
3443 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3444 ! Derivatives of the elements of A in virtual-bond vectors
3445           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3446           do k=1,3
3447             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3448             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3449             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3450             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3451             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3452             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3453             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3454             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3455             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3456             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3457             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3458             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3459           enddo
3460 ! Compute radial contributions to the gradient
3461           facr=-3.0d0*rrmij
3462           a22der=a22*facr
3463           a23der=a23*facr
3464           a32der=a32*facr
3465           a33der=a33*facr
3466           agg(1,1)=a22der*xj
3467           agg(2,1)=a22der*yj
3468           agg(3,1)=a22der*zj
3469           agg(1,2)=a23der*xj
3470           agg(2,2)=a23der*yj
3471           agg(3,2)=a23der*zj
3472           agg(1,3)=a32der*xj
3473           agg(2,3)=a32der*yj
3474           agg(3,3)=a32der*zj
3475           agg(1,4)=a33der*xj
3476           agg(2,4)=a33der*yj
3477           agg(3,4)=a33der*zj
3478 ! Add the contributions coming from er
3479           fac3=-3.0d0*fac
3480           do k=1,3
3481             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3482             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3483             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3484             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3485           enddo
3486           do k=1,3
3487 ! Derivatives in DC(i)
3488 !grad            ghalf1=0.5d0*agg(k,1)
3489 !grad            ghalf2=0.5d0*agg(k,2)
3490 !grad            ghalf3=0.5d0*agg(k,3)
3491 !grad            ghalf4=0.5d0*agg(k,4)
3492             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3493             -3.0d0*uryg(k,2)*vry)!+ghalf1
3494             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3495             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3496             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3497             -3.0d0*urzg(k,2)*vry)!+ghalf3
3498             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3499             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3500 ! Derivatives in DC(i+1)
3501             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3502             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3503             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3504             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3505             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3506             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3507             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3508             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3509 ! Derivatives in DC(j)
3510             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3511             -3.0d0*vryg(k,2)*ury)!+ghalf1
3512             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3513             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3514             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3515             -3.0d0*vryg(k,2)*urz)!+ghalf3
3516             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3517             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3518 ! Derivatives in DC(j+1) or DC(nres-1)
3519             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3520             -3.0d0*vryg(k,3)*ury)
3521             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3522             -3.0d0*vrzg(k,3)*ury)
3523             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3524             -3.0d0*vryg(k,3)*urz)
3525             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3526             -3.0d0*vrzg(k,3)*urz)
3527 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3528 !grad              do l=1,4
3529 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3530 !grad              enddo
3531 !grad            endif
3532           enddo
3533           acipa(1,1)=a22
3534           acipa(1,2)=a23
3535           acipa(2,1)=a32
3536           acipa(2,2)=a33
3537           a22=-a22
3538           a23=-a23
3539           do l=1,2
3540             do k=1,3
3541               agg(k,l)=-agg(k,l)
3542               aggi(k,l)=-aggi(k,l)
3543               aggi1(k,l)=-aggi1(k,l)
3544               aggj(k,l)=-aggj(k,l)
3545               aggj1(k,l)=-aggj1(k,l)
3546             enddo
3547           enddo
3548           if (j.lt.nres-1) then
3549             a22=-a22
3550             a32=-a32
3551             do l=1,3,2
3552               do k=1,3
3553                 agg(k,l)=-agg(k,l)
3554                 aggi(k,l)=-aggi(k,l)
3555                 aggi1(k,l)=-aggi1(k,l)
3556                 aggj(k,l)=-aggj(k,l)
3557                 aggj1(k,l)=-aggj1(k,l)
3558               enddo
3559             enddo
3560           else
3561             a22=-a22
3562             a23=-a23
3563             a32=-a32
3564             a33=-a33
3565             do l=1,4
3566               do k=1,3
3567                 agg(k,l)=-agg(k,l)
3568                 aggi(k,l)=-aggi(k,l)
3569                 aggi1(k,l)=-aggi1(k,l)
3570                 aggj(k,l)=-aggj(k,l)
3571                 aggj1(k,l)=-aggj1(k,l)
3572               enddo
3573             enddo
3574           endif
3575           ENDIF ! WCORR
3576           IF (wel_loc.gt.0.0d0) THEN
3577 ! Contribution to the local-electrostatic energy coming from the i-j pair
3578           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3579            +a33*muij(4)
3580           if (shield_mode.eq.0) then
3581            fac_shield(i)=1.0
3582            fac_shield(j)=1.0
3583           endif
3584           eel_loc_ij=eel_loc_ij &
3585          *fac_shield(i)*fac_shield(j) &
3586          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3587 !C Now derivative over eel_loc
3588           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3589          (shield_mode.gt.0)) then
3590 !C          print *,i,j
3591
3592           do ilist=1,ishield_list(i)
3593            iresshield=shield_list(ilist,i)
3594            do k=1,3
3595            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3596                                                 /fac_shield(i)&
3597            *sss_ele_cut
3598            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3599                    rlocshield  &
3600           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3601           *sss_ele_cut
3602
3603             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3604            +rlocshield
3605            enddo
3606           enddo
3607           do ilist=1,ishield_list(j)
3608            iresshield=shield_list(ilist,j)
3609            do k=1,3
3610            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3611                                             /fac_shield(j)   &
3612             *sss_ele_cut
3613            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3614                    rlocshield  &
3615       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3616        *sss_ele_cut
3617
3618            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3619                   +rlocshield
3620
3621            enddo
3622           enddo
3623
3624           do k=1,3
3625             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3626                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3627                     *sss_ele_cut
3628             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3629                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3630                     *sss_ele_cut
3631             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3632                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3633                     *sss_ele_cut
3634             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3635                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3636                     *sss_ele_cut
3637
3638            enddo
3639            endif
3640
3641
3642 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3643 !           eel_loc_ij=0.0
3644           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3645                   'eelloc',i,j,eel_loc_ij
3646 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3647 !          if (energy_dec) write (iout,*) "muij",muij
3648 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3649
3650           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3651 ! Partial derivatives in virtual-bond dihedral angles gamma
3652           if (i.gt.1) &
3653           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3654                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3655                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3656                  *sss_ele_cut  &
3657           *fac_shield(i)*fac_shield(j) &
3658           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3659
3660           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3661                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3662                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3663                  *sss_ele_cut &
3664           *fac_shield(i)*fac_shield(j) &
3665           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3666 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3667 !          do l=1,3
3668 !            ggg(1)=(agg(1,1)*muij(1)+ &
3669 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3670 !            *sss_ele_cut &
3671 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3672 !            ggg(2)=(agg(2,1)*muij(1)+ &
3673 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3674 !            *sss_ele_cut &
3675 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3676 !            ggg(3)=(agg(3,1)*muij(1)+ &
3677 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3678 !            *sss_ele_cut &
3679 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3680            xtemp(1)=xj
3681            xtemp(2)=yj
3682            xtemp(3)=zj
3683
3684            do l=1,3
3685             ggg(l)=(agg(l,1)*muij(1)+ &
3686                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3687             *sss_ele_cut &
3688              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3689
3690             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3691             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3692 !grad            ghalf=0.5d0*ggg(l)
3693 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3694 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3695           enddo
3696             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
3697           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
3698           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3699
3700             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
3701           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
3702           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3703
3704 !grad          do k=i+1,j2
3705 !grad            do l=1,3
3706 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3707 !grad            enddo
3708 !grad          enddo
3709 ! Remaining derivatives of eello
3710           do l=1,3
3711             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
3712                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
3713             *sss_ele_cut
3714 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3715             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
3716                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
3717             +aggi1(l,4)*muij(4))&
3718             *sss_ele_cut
3719 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3720             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
3721                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
3722             *sss_ele_cut
3723 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3724             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
3725                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
3726             +aggj1(l,4)*muij(4))&
3727             *sss_ele_cut
3728 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3729           enddo
3730           ENDIF
3731 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3732 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3733           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3734              .and. num_conti.le.maxconts) then
3735 !            write (iout,*) i,j," entered corr"
3736 !
3737 ! Calculate the contact function. The ith column of the array JCONT will
3738 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3739 ! greater than I). The arrays FACONT and GACONT will contain the values of
3740 ! the contact function and its derivative.
3741 !           r0ij=1.02D0*rpp(iteli,itelj)
3742 !           r0ij=1.11D0*rpp(iteli,itelj)
3743             r0ij=2.20D0*rpp(iteli,itelj)
3744 !           r0ij=1.55D0*rpp(iteli,itelj)
3745             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3746 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3747             if (fcont.gt.0.0D0) then
3748               num_conti=num_conti+1
3749               if (num_conti.gt.maxconts) then
3750 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3751 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3752                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3753                                ' will skip next contacts for this conf.', num_conti
3754               else
3755                 jcont_hb(num_conti,i)=j
3756 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3757 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3758                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3759                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3760 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3761 !  terms.
3762                 d_cont(num_conti,i)=rij
3763 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3764 !     --- Electrostatic-interaction matrix ---
3765                 a_chuj(1,1,num_conti,i)=a22
3766                 a_chuj(1,2,num_conti,i)=a23
3767                 a_chuj(2,1,num_conti,i)=a32
3768                 a_chuj(2,2,num_conti,i)=a33
3769 !     --- Gradient of rij
3770                 do kkk=1,3
3771                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3772                 enddo
3773                 kkll=0
3774                 do k=1,2
3775                   do l=1,2
3776                     kkll=kkll+1
3777                     do m=1,3
3778                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3779                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3780                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3781                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3782                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3783                     enddo
3784                   enddo
3785                 enddo
3786                 ENDIF
3787                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3788 ! Calculate contact energies
3789                 cosa4=4.0D0*cosa
3790                 wij=cosa-3.0D0*cosb*cosg
3791                 cosbg1=cosb+cosg
3792                 cosbg2=cosb-cosg
3793 !               fac3=dsqrt(-ael6i)/r0ij**3
3794                 fac3=dsqrt(-ael6i)*r3ij
3795 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3796                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3797                 if (ees0tmp.gt.0) then
3798                   ees0pij=dsqrt(ees0tmp)
3799                 else
3800                   ees0pij=0
3801                 endif
3802                 if (shield_mode.eq.0) then
3803                 fac_shield(i)=1.0d0
3804                 fac_shield(j)=1.0d0
3805                 else
3806                 ees0plist(num_conti,i)=j
3807                 endif
3808 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3809                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3810                 if (ees0tmp.gt.0) then
3811                   ees0mij=dsqrt(ees0tmp)
3812                 else
3813                   ees0mij=0
3814                 endif
3815 !               ees0mij=0.0D0
3816                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
3817                      *sss_ele_cut &
3818                      *fac_shield(i)*fac_shield(j)
3819
3820                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
3821                      *sss_ele_cut &
3822                      *fac_shield(i)*fac_shield(j)
3823
3824 ! Diagnostics. Comment out or remove after debugging!
3825 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3826 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3827 !               ees0m(num_conti,i)=0.0D0
3828 ! End diagnostics.
3829 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3830 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3831 ! Angular derivatives of the contact function
3832                 ees0pij1=fac3/ees0pij
3833                 ees0mij1=fac3/ees0mij
3834                 fac3p=-3.0D0*fac3*rrmij
3835                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3836                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3837 !               ees0mij1=0.0D0
3838                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3839                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3840                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3841                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3842                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3843                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3844                 ecosap=ecosa1+ecosa2
3845                 ecosbp=ecosb1+ecosb2
3846                 ecosgp=ecosg1+ecosg2
3847                 ecosam=ecosa1-ecosa2
3848                 ecosbm=ecosb1-ecosb2
3849                 ecosgm=ecosg1-ecosg2
3850 ! Diagnostics
3851 !               ecosap=ecosa1
3852 !               ecosbp=ecosb1
3853 !               ecosgp=ecosg1
3854 !               ecosam=0.0D0
3855 !               ecosbm=0.0D0
3856 !               ecosgm=0.0D0
3857 ! End diagnostics
3858                 facont_hb(num_conti,i)=fcont
3859                 fprimcont=fprimcont/rij
3860 !d              facont_hb(num_conti,i)=1.0D0
3861 ! Following line is for diagnostics.
3862 !d              fprimcont=0.0D0
3863                 do k=1,3
3864                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3865                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3866                 enddo
3867                 do k=1,3
3868                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3869                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3870                 enddo
3871                 gggp(1)=gggp(1)+ees0pijp*xj &
3872                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3873                 gggp(2)=gggp(2)+ees0pijp*yj &
3874                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3875                 gggp(3)=gggp(3)+ees0pijp*zj &
3876                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3877
3878                 gggm(1)=gggm(1)+ees0mijp*xj &
3879                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
3880
3881                 gggm(2)=gggm(2)+ees0mijp*yj &
3882                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
3883
3884                 gggm(3)=gggm(3)+ees0mijp*zj &
3885                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
3886
3887 ! Derivatives due to the contact function
3888                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3889                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3890                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3891                 do k=1,3
3892 !
3893 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
3894 !          following the change of gradient-summation algorithm.
3895 !
3896 !grad                  ghalfp=0.5D0*gggp(k)
3897 !grad                  ghalfm=0.5D0*gggm(k)
3898                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
3899                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3900                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3901                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3902
3903                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
3904                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3905                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3906                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3907
3908                   gacontp_hb3(k,num_conti,i)=gggp(k) &
3909                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3910
3911                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
3912                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3913                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
3914                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3915
3916                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
3917                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3918                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
3919                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3920
3921                   gacontm_hb3(k,num_conti,i)=gggm(k) &
3922                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
3923
3924                 enddo
3925 ! Diagnostics. Comment out or remove after debugging!
3926 !diag           do k=1,3
3927 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
3928 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
3929 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
3930 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
3931 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
3932 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
3933 !diag           enddo
3934               ENDIF ! wcorr
3935               endif  ! num_conti.le.maxconts
3936             endif  ! fcont.gt.0
3937           endif    ! j.gt.i+1
3938           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3939             do k=1,4
3940               do l=1,3
3941                 ghalf=0.5d0*agg(l,k)
3942                 aggi(l,k)=aggi(l,k)+ghalf
3943                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3944                 aggj(l,k)=aggj(l,k)+ghalf
3945               enddo
3946             enddo
3947             if (j.eq.nres-1 .and. i.lt.j-2) then
3948               do k=1,4
3949                 do l=1,3
3950                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3951                 enddo
3952               enddo
3953             endif
3954           endif
3955  128  continue
3956 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
3957       return
3958       end subroutine eelecij
3959 !-----------------------------------------------------------------------------
3960       subroutine eturn3(i,eello_turn3)
3961 ! Third- and fourth-order contributions from turns
3962
3963       use comm_locel
3964 !      implicit real*8 (a-h,o-z)
3965 !      include 'DIMENSIONS'
3966 !      include 'COMMON.IOUNITS'
3967 !      include 'COMMON.GEO'
3968 !      include 'COMMON.VAR'
3969 !      include 'COMMON.LOCAL'
3970 !      include 'COMMON.CHAIN'
3971 !      include 'COMMON.DERIV'
3972 !      include 'COMMON.INTERACT'
3973 !      include 'COMMON.CONTACTS'
3974 !      include 'COMMON.TORSION'
3975 !      include 'COMMON.VECTORS'
3976 !      include 'COMMON.FFIELD'
3977 !      include 'COMMON.CONTROL'
3978       real(kind=8),dimension(3) :: ggg
3979       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
3980         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
3981       real(kind=8),dimension(2) :: auxvec,auxvec1
3982 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3983       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
3984 !el      integer :: num_conti,j1,j2
3985 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3986 !el        dz_normi,xmedi,ymedi,zmedi
3987
3988 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3989 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3990 !el         num_conti,j1,j2
3991 !el local variables
3992       integer :: i,j,l,k,ilist,iresshield
3993       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
3994
3995       j=i+2
3996 !      write (iout,*) "eturn3",i,j,j1,j2
3997           zj=(c(3,j)+c(3,j+1))/2.0d0
3998           zj=mod(zj,boxzsize)
3999           if (zj.lt.0) zj=zj+boxzsize
4000           if ((zj.lt.0)) write (*,*) "CHUJ"
4001        if ((zj.gt.bordlipbot)  &
4002         .and.(zj.lt.bordliptop)) then
4003 !C the energy transfer exist
4004         if (zj.lt.buflipbot) then
4005 !C what fraction I am in
4006          fracinbuf=1.0d0-     &
4007              ((zj-bordlipbot)/lipbufthick)
4008 !C lipbufthick is thickenes of lipid buffore
4009          sslipj=sscalelip(fracinbuf)
4010          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4011         elseif (zj.gt.bufliptop) then
4012          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4013          sslipj=sscalelip(fracinbuf)
4014          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4015         else
4016          sslipj=1.0d0
4017          ssgradlipj=0.0
4018         endif
4019        else
4020          sslipj=0.0d0
4021          ssgradlipj=0.0
4022        endif
4023
4024       a_temp(1,1)=a22
4025       a_temp(1,2)=a23
4026       a_temp(2,1)=a32
4027       a_temp(2,2)=a33
4028 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4029 !
4030 !               Third-order contributions
4031 !
4032 !                 (i+2)o----(i+3)
4033 !                      | |
4034 !                      | |
4035 !                 (i+1)o----i
4036 !
4037 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4038 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4039         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4040         call transpose2(auxmat(1,1),auxmat1(1,1))
4041         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4042         if (shield_mode.eq.0) then
4043         fac_shield(i)=1.0d0
4044         fac_shield(j)=1.0d0
4045         endif
4046
4047         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4048          *fac_shield(i)*fac_shield(j)  &
4049          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4050         eello_t3= &
4051         0.5d0*(pizda(1,1)+pizda(2,2)) &
4052         *fac_shield(i)*fac_shield(j)
4053
4054         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4055                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4056           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4057        (shield_mode.gt.0)) then
4058 !C          print *,i,j
4059
4060           do ilist=1,ishield_list(i)
4061            iresshield=shield_list(ilist,i)
4062            do k=1,3
4063            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4064            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4065                    rlocshield &
4066            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4067             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4068              +rlocshield
4069            enddo
4070           enddo
4071           do ilist=1,ishield_list(j)
4072            iresshield=shield_list(ilist,j)
4073            do k=1,3
4074            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4075            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4076                    rlocshield &
4077            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4078            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4079                   +rlocshield
4080
4081            enddo
4082           enddo
4083
4084           do k=1,3
4085             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4086                    grad_shield(k,i)*eello_t3/fac_shield(i)
4087             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4088                    grad_shield(k,j)*eello_t3/fac_shield(j)
4089             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4090                    grad_shield(k,i)*eello_t3/fac_shield(i)
4091             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4092                    grad_shield(k,j)*eello_t3/fac_shield(j)
4093            enddo
4094            endif
4095
4096 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4097 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4098 !d     &    ' eello_turn3_num',4*eello_turn3_num
4099 ! Derivatives in gamma(i)
4100         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4101         call transpose2(auxmat2(1,1),auxmat3(1,1))
4102         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4103         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4104 ! Derivatives in gamma(i+1)
4105         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4106         call transpose2(auxmat2(1,1),auxmat3(1,1))
4107         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4108         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4109           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4110           *fac_shield(i)*fac_shield(j)        &
4111           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4112
4113 ! Cartesian derivatives
4114         do l=1,3
4115 !            ghalf1=0.5d0*agg(l,1)
4116 !            ghalf2=0.5d0*agg(l,2)
4117 !            ghalf3=0.5d0*agg(l,3)
4118 !            ghalf4=0.5d0*agg(l,4)
4119           a_temp(1,1)=aggi(l,1)!+ghalf1
4120           a_temp(1,2)=aggi(l,2)!+ghalf2
4121           a_temp(2,1)=aggi(l,3)!+ghalf3
4122           a_temp(2,2)=aggi(l,4)!+ghalf4
4123           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4124           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4125             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4126           *fac_shield(i)*fac_shield(j)      &
4127           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4128
4129           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4130           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4131           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4132           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4133           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4134           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4135             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4136           *fac_shield(i)*fac_shield(j)        &
4137           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4138
4139           a_temp(1,1)=aggj(l,1)!+ghalf1
4140           a_temp(1,2)=aggj(l,2)!+ghalf2
4141           a_temp(2,1)=aggj(l,3)!+ghalf3
4142           a_temp(2,2)=aggj(l,4)!+ghalf4
4143           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4144           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4145             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4146           *fac_shield(i)*fac_shield(j)      &
4147           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4148
4149           a_temp(1,1)=aggj1(l,1)
4150           a_temp(1,2)=aggj1(l,2)
4151           a_temp(2,1)=aggj1(l,3)
4152           a_temp(2,2)=aggj1(l,4)
4153           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4154           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4155             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4156           *fac_shield(i)*fac_shield(j)        &
4157           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4158         enddo
4159          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4160           ssgradlipi*eello_t3/4.0d0*lipscale
4161          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4162           ssgradlipj*eello_t3/4.0d0*lipscale
4163          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4164           ssgradlipi*eello_t3/4.0d0*lipscale
4165          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4166           ssgradlipj*eello_t3/4.0d0*lipscale
4167
4168       return
4169       end subroutine eturn3
4170 !-----------------------------------------------------------------------------
4171       subroutine eturn4(i,eello_turn4)
4172 ! Third- and fourth-order contributions from turns
4173
4174       use comm_locel
4175 !      implicit real*8 (a-h,o-z)
4176 !      include 'DIMENSIONS'
4177 !      include 'COMMON.IOUNITS'
4178 !      include 'COMMON.GEO'
4179 !      include 'COMMON.VAR'
4180 !      include 'COMMON.LOCAL'
4181 !      include 'COMMON.CHAIN'
4182 !      include 'COMMON.DERIV'
4183 !      include 'COMMON.INTERACT'
4184 !      include 'COMMON.CONTACTS'
4185 !      include 'COMMON.TORSION'
4186 !      include 'COMMON.VECTORS'
4187 !      include 'COMMON.FFIELD'
4188 !      include 'COMMON.CONTROL'
4189       real(kind=8),dimension(3) :: ggg
4190       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4191         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4192       real(kind=8),dimension(2) :: auxvec,auxvec1
4193 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4194       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4195 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4196 !el        dz_normi,xmedi,ymedi,zmedi
4197 !el      integer :: num_conti,j1,j2
4198 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4199 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4200 !el          num_conti,j1,j2
4201 !el local variables
4202       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4203       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4204          rlocshield
4205
4206       j=i+3
4207 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4208 !
4209 !               Fourth-order contributions
4210 !
4211 !                 (i+3)o----(i+4)
4212 !                     /  |
4213 !               (i+2)o   |
4214 !                     \  |
4215 !                 (i+1)o----i
4216 !
4217 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4218 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4219 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4220           zj=(c(3,j)+c(3,j+1))/2.0d0
4221           zj=mod(zj,boxzsize)
4222           if (zj.lt.0) zj=zj+boxzsize
4223        if ((zj.gt.bordlipbot)  &
4224         .and.(zj.lt.bordliptop)) then
4225 !C the energy transfer exist
4226         if (zj.lt.buflipbot) then
4227 !C what fraction I am in
4228          fracinbuf=1.0d0-     &
4229              ((zj-bordlipbot)/lipbufthick)
4230 !C lipbufthick is thickenes of lipid buffore
4231          sslipj=sscalelip(fracinbuf)
4232          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4233         elseif (zj.gt.bufliptop) then
4234          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4235          sslipj=sscalelip(fracinbuf)
4236          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4237         else
4238          sslipj=1.0d0
4239          ssgradlipj=0.0
4240         endif
4241        else
4242          sslipj=0.0d0
4243          ssgradlipj=0.0
4244        endif
4245
4246         a_temp(1,1)=a22
4247         a_temp(1,2)=a23
4248         a_temp(2,1)=a32
4249         a_temp(2,2)=a33
4250         iti1=itortyp(itype(i+1))
4251         iti2=itortyp(itype(i+2))
4252         iti3=itortyp(itype(i+3))
4253 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4254         call transpose2(EUg(1,1,i+1),e1t(1,1))
4255         call transpose2(Eug(1,1,i+2),e2t(1,1))
4256         call transpose2(Eug(1,1,i+3),e3t(1,1))
4257         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4258         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4259         s1=scalar2(b1(1,iti2),auxvec(1))
4260         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4261         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4262         s2=scalar2(b1(1,iti1),auxvec(1))
4263         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4264         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4265         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4266         if (shield_mode.eq.0) then
4267         fac_shield(i)=1.0
4268         fac_shield(j)=1.0
4269         endif
4270
4271         eello_turn4=eello_turn4-(s1+s2+s3) &
4272         *fac_shield(i)*fac_shield(j)       &
4273         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4274         eello_t4=-(s1+s2+s3)  &
4275           *fac_shield(i)*fac_shield(j)
4276 !C Now derivative over shield:
4277           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4278          (shield_mode.gt.0)) then
4279 !C          print *,i,j
4280
4281           do ilist=1,ishield_list(i)
4282            iresshield=shield_list(ilist,i)
4283            do k=1,3
4284            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4285            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4286                    rlocshield &
4287             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4288             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4289            +rlocshield
4290            enddo
4291           enddo
4292           do ilist=1,ishield_list(j)
4293            iresshield=shield_list(ilist,j)
4294            do k=1,3
4295            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4296            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4297                    rlocshield  &
4298            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4299            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4300                   +rlocshield
4301
4302            enddo
4303           enddo
4304
4305           do k=1,3
4306             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4307                    grad_shield(k,i)*eello_t4/fac_shield(i)
4308             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4309                    grad_shield(k,j)*eello_t4/fac_shield(j)
4310             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4311                    grad_shield(k,i)*eello_t4/fac_shield(i)
4312             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4313                    grad_shield(k,j)*eello_t4/fac_shield(j)
4314            enddo
4315            endif
4316
4317         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4318            'eturn4',i,j,-(s1+s2+s3)
4319 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4320 !d     &    ' eello_turn4_num',8*eello_turn4_num
4321 ! Derivatives in gamma(i)
4322         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4323         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4324         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4325         s1=scalar2(b1(1,iti2),auxvec(1))
4326         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4327         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4328         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4329        *fac_shield(i)*fac_shield(j)  &
4330        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4331
4332 ! Derivatives in gamma(i+1)
4333         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4334         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4335         s2=scalar2(b1(1,iti1),auxvec(1))
4336         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4337         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4338         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4339         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4340        *fac_shield(i)*fac_shield(j)  &
4341        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4342
4343 ! Derivatives in gamma(i+2)
4344         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4345         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4346         s1=scalar2(b1(1,iti2),auxvec(1))
4347         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4348         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4349         s2=scalar2(b1(1,iti1),auxvec(1))
4350         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4351         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4352         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4353         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4354        *fac_shield(i)*fac_shield(j)  &
4355        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4356
4357 ! Cartesian derivatives
4358 ! Derivatives of this turn contributions in DC(i+2)
4359         if (j.lt.nres-1) then
4360           do l=1,3
4361             a_temp(1,1)=agg(l,1)
4362             a_temp(1,2)=agg(l,2)
4363             a_temp(2,1)=agg(l,3)
4364             a_temp(2,2)=agg(l,4)
4365             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4366             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4367             s1=scalar2(b1(1,iti2),auxvec(1))
4368             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4369             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4370             s2=scalar2(b1(1,iti1),auxvec(1))
4371             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4372             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4373             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4374             ggg(l)=-(s1+s2+s3)
4375             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4376           enddo
4377         endif
4378 ! Remaining derivatives of this turn contribution
4379         do l=1,3
4380           a_temp(1,1)=aggi(l,1)
4381           a_temp(1,2)=aggi(l,2)
4382           a_temp(2,1)=aggi(l,3)
4383           a_temp(2,2)=aggi(l,4)
4384           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4385           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4386           s1=scalar2(b1(1,iti2),auxvec(1))
4387           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4388           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4389           s2=scalar2(b1(1,iti1),auxvec(1))
4390           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4391           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4392           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4393           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4394          *fac_shield(i)*fac_shield(j)  &
4395          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4396
4397
4398           a_temp(1,1)=aggi1(l,1)
4399           a_temp(1,2)=aggi1(l,2)
4400           a_temp(2,1)=aggi1(l,3)
4401           a_temp(2,2)=aggi1(l,4)
4402           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4403           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4404           s1=scalar2(b1(1,iti2),auxvec(1))
4405           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4406           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4407           s2=scalar2(b1(1,iti1),auxvec(1))
4408           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4409           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4410           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4411           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4412          *fac_shield(i)*fac_shield(j)  &
4413          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4414
4415
4416           a_temp(1,1)=aggj(l,1)
4417           a_temp(1,2)=aggj(l,2)
4418           a_temp(2,1)=aggj(l,3)
4419           a_temp(2,2)=aggj(l,4)
4420           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4421           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4422           s1=scalar2(b1(1,iti2),auxvec(1))
4423           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4424           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4425           s2=scalar2(b1(1,iti1),auxvec(1))
4426           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4427           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4428           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4429           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4430          *fac_shield(i)*fac_shield(j)  &
4431          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4432
4433
4434           a_temp(1,1)=aggj1(l,1)
4435           a_temp(1,2)=aggj1(l,2)
4436           a_temp(2,1)=aggj1(l,3)
4437           a_temp(2,2)=aggj1(l,4)
4438           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4439           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4440           s1=scalar2(b1(1,iti2),auxvec(1))
4441           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4442           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4443           s2=scalar2(b1(1,iti1),auxvec(1))
4444           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4445           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4446           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4447 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4448           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4449          *fac_shield(i)*fac_shield(j)  &
4450          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4451
4452         enddo
4453          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4454           ssgradlipi*eello_t4/4.0d0*lipscale
4455          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4456           ssgradlipj*eello_t4/4.0d0*lipscale
4457          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4458           ssgradlipi*eello_t4/4.0d0*lipscale
4459          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4460           ssgradlipj*eello_t4/4.0d0*lipscale
4461
4462       return
4463       end subroutine eturn4
4464 !-----------------------------------------------------------------------------
4465       subroutine unormderiv(u,ugrad,unorm,ungrad)
4466 ! This subroutine computes the derivatives of a normalized vector u, given
4467 ! the derivatives computed without normalization conditions, ugrad. Returns
4468 ! ungrad.
4469 !      implicit none
4470       real(kind=8),dimension(3) :: u,vec
4471       real(kind=8),dimension(3,3) ::ugrad,ungrad
4472       real(kind=8) :: unorm     !,scalar
4473       integer :: i,j
4474 !      write (2,*) 'ugrad',ugrad
4475 !      write (2,*) 'u',u
4476       do i=1,3
4477         vec(i)=scalar(ugrad(1,i),u(1))
4478       enddo
4479 !      write (2,*) 'vec',vec
4480       do i=1,3
4481         do j=1,3
4482           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4483         enddo
4484       enddo
4485 !      write (2,*) 'ungrad',ungrad
4486       return
4487       end subroutine unormderiv
4488 !-----------------------------------------------------------------------------
4489       subroutine escp_soft_sphere(evdw2,evdw2_14)
4490 !
4491 ! This subroutine calculates the excluded-volume interaction energy between
4492 ! peptide-group centers and side chains and its gradient in virtual-bond and
4493 ! side-chain vectors.
4494 !
4495 !      implicit real*8 (a-h,o-z)
4496 !      include 'DIMENSIONS'
4497 !      include 'COMMON.GEO'
4498 !      include 'COMMON.VAR'
4499 !      include 'COMMON.LOCAL'
4500 !      include 'COMMON.CHAIN'
4501 !      include 'COMMON.DERIV'
4502 !      include 'COMMON.INTERACT'
4503 !      include 'COMMON.FFIELD'
4504 !      include 'COMMON.IOUNITS'
4505 !      include 'COMMON.CONTROL'
4506       real(kind=8),dimension(3) :: ggg
4507 !el local variables
4508       integer :: i,iint,j,k,iteli,itypj
4509       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4510                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4511
4512       evdw2=0.0D0
4513       evdw2_14=0.0d0
4514       r0_scp=4.5d0
4515 !d    print '(a)','Enter ESCP'
4516 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4517       do i=iatscp_s,iatscp_e
4518         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4519         iteli=itel(i)
4520         xi=0.5D0*(c(1,i)+c(1,i+1))
4521         yi=0.5D0*(c(2,i)+c(2,i+1))
4522         zi=0.5D0*(c(3,i)+c(3,i+1))
4523
4524         do iint=1,nscp_gr(i)
4525
4526         do j=iscpstart(i,iint),iscpend(i,iint)
4527           if (itype(j).eq.ntyp1) cycle
4528           itypj=iabs(itype(j))
4529 ! Uncomment following three lines for SC-p interactions
4530 !         xj=c(1,nres+j)-xi
4531 !         yj=c(2,nres+j)-yi
4532 !         zj=c(3,nres+j)-zi
4533 ! Uncomment following three lines for Ca-p interactions
4534           xj=c(1,j)-xi
4535           yj=c(2,j)-yi
4536           zj=c(3,j)-zi
4537           rij=xj*xj+yj*yj+zj*zj
4538           r0ij=r0_scp
4539           r0ijsq=r0ij*r0ij
4540           if (rij.lt.r0ijsq) then
4541             evdwij=0.25d0*(rij-r0ijsq)**2
4542             fac=rij-r0ijsq
4543           else
4544             evdwij=0.0d0
4545             fac=0.0d0
4546           endif
4547           evdw2=evdw2+evdwij
4548 !
4549 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4550 !
4551           ggg(1)=xj*fac
4552           ggg(2)=yj*fac
4553           ggg(3)=zj*fac
4554 !grad          if (j.lt.i) then
4555 !d          write (iout,*) 'j<i'
4556 ! Uncomment following three lines for SC-p interactions
4557 !           do k=1,3
4558 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4559 !           enddo
4560 !grad          else
4561 !d          write (iout,*) 'j>i'
4562 !grad            do k=1,3
4563 !grad              ggg(k)=-ggg(k)
4564 ! Uncomment following line for SC-p interactions
4565 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4566 !grad            enddo
4567 !grad          endif
4568 !grad          do k=1,3
4569 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4570 !grad          enddo
4571 !grad          kstart=min0(i+1,j)
4572 !grad          kend=max0(i-1,j-1)
4573 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4574 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4575 !grad          do k=kstart,kend
4576 !grad            do l=1,3
4577 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4578 !grad            enddo
4579 !grad          enddo
4580           do k=1,3
4581             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4582             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4583           enddo
4584         enddo
4585
4586         enddo ! iint
4587       enddo ! i
4588       return
4589       end subroutine escp_soft_sphere
4590 !-----------------------------------------------------------------------------
4591       subroutine escp(evdw2,evdw2_14)
4592 !
4593 ! This subroutine calculates the excluded-volume interaction energy between
4594 ! peptide-group centers and side chains and its gradient in virtual-bond and
4595 ! side-chain vectors.
4596 !
4597 !      implicit real*8 (a-h,o-z)
4598 !      include 'DIMENSIONS'
4599 !      include 'COMMON.GEO'
4600 !      include 'COMMON.VAR'
4601 !      include 'COMMON.LOCAL'
4602 !      include 'COMMON.CHAIN'
4603 !      include 'COMMON.DERIV'
4604 !      include 'COMMON.INTERACT'
4605 !      include 'COMMON.FFIELD'
4606 !      include 'COMMON.IOUNITS'
4607 !      include 'COMMON.CONTROL'
4608       real(kind=8),dimension(3) :: ggg
4609 !el local variables
4610       integer :: i,iint,j,k,iteli,itypj,subchap
4611       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4612                    e1,e2,evdwij,rij
4613       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4614                     dist_temp, dist_init
4615       integer xshift,yshift,zshift
4616
4617       evdw2=0.0D0
4618       evdw2_14=0.0d0
4619 !d    print '(a)','Enter ESCP'
4620 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4621       do i=iatscp_s,iatscp_e
4622         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4623         iteli=itel(i)
4624         xi=0.5D0*(c(1,i)+c(1,i+1))
4625         yi=0.5D0*(c(2,i)+c(2,i+1))
4626         zi=0.5D0*(c(3,i)+c(3,i+1))
4627           xi=mod(xi,boxxsize)
4628           if (xi.lt.0) xi=xi+boxxsize
4629           yi=mod(yi,boxysize)
4630           if (yi.lt.0) yi=yi+boxysize
4631           zi=mod(zi,boxzsize)
4632           if (zi.lt.0) zi=zi+boxzsize
4633
4634         do iint=1,nscp_gr(i)
4635
4636         do j=iscpstart(i,iint),iscpend(i,iint)
4637           itypj=iabs(itype(j))
4638           if (itypj.eq.ntyp1) cycle
4639 ! Uncomment following three lines for SC-p interactions
4640 !         xj=c(1,nres+j)-xi
4641 !         yj=c(2,nres+j)-yi
4642 !         zj=c(3,nres+j)-zi
4643 ! Uncomment following three lines for Ca-p interactions
4644 !          xj=c(1,j)-xi
4645 !          yj=c(2,j)-yi
4646 !          zj=c(3,j)-zi
4647           xj=c(1,j)
4648           yj=c(2,j)
4649           zj=c(3,j)
4650           xj=mod(xj,boxxsize)
4651           if (xj.lt.0) xj=xj+boxxsize
4652           yj=mod(yj,boxysize)
4653           if (yj.lt.0) yj=yj+boxysize
4654           zj=mod(zj,boxzsize)
4655           if (zj.lt.0) zj=zj+boxzsize
4656       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4657       xj_safe=xj
4658       yj_safe=yj
4659       zj_safe=zj
4660       subchap=0
4661       do xshift=-1,1
4662       do yshift=-1,1
4663       do zshift=-1,1
4664           xj=xj_safe+xshift*boxxsize
4665           yj=yj_safe+yshift*boxysize
4666           zj=zj_safe+zshift*boxzsize
4667           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4668           if(dist_temp.lt.dist_init) then
4669             dist_init=dist_temp
4670             xj_temp=xj
4671             yj_temp=yj
4672             zj_temp=zj
4673             subchap=1
4674           endif
4675        enddo
4676        enddo
4677        enddo
4678        if (subchap.eq.1) then
4679           xj=xj_temp-xi
4680           yj=yj_temp-yi
4681           zj=zj_temp-zi
4682        else
4683           xj=xj_safe-xi
4684           yj=yj_safe-yi
4685           zj=zj_safe-zi
4686        endif
4687
4688           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4689           rij=dsqrt(1.0d0/rrij)
4690             sss_ele_cut=sscale_ele(rij)
4691             sss_ele_grad=sscagrad_ele(rij)
4692 !            print *,sss_ele_cut,sss_ele_grad,&
4693 !            (rij),r_cut_ele,rlamb_ele
4694             if (sss_ele_cut.le.0.0) cycle
4695           fac=rrij**expon2
4696           e1=fac*fac*aad(itypj,iteli)
4697           e2=fac*bad(itypj,iteli)
4698           if (iabs(j-i) .le. 2) then
4699             e1=scal14*e1
4700             e2=scal14*e2
4701             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
4702           endif
4703           evdwij=e1+e2
4704           evdw2=evdw2+evdwij*sss_ele_cut
4705 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
4706 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
4707           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4708              'evdw2',i,j,evdwij
4709 !
4710 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4711 !
4712           fac=-(evdwij+e1)*rrij*sss_ele_cut
4713           fac=fac+evdwij*sss_ele_grad/rij/expon
4714           ggg(1)=xj*fac
4715           ggg(2)=yj*fac
4716           ggg(3)=zj*fac
4717 !grad          if (j.lt.i) then
4718 !d          write (iout,*) 'j<i'
4719 ! Uncomment following three lines for SC-p interactions
4720 !           do k=1,3
4721 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4722 !           enddo
4723 !grad          else
4724 !d          write (iout,*) 'j>i'
4725 !grad            do k=1,3
4726 !grad              ggg(k)=-ggg(k)
4727 ! Uncomment following line for SC-p interactions
4728 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4729 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4730 !grad            enddo
4731 !grad          endif
4732 !grad          do k=1,3
4733 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4734 !grad          enddo
4735 !grad          kstart=min0(i+1,j)
4736 !grad          kend=max0(i-1,j-1)
4737 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4738 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4739 !grad          do k=kstart,kend
4740 !grad            do l=1,3
4741 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4742 !grad            enddo
4743 !grad          enddo
4744           do k=1,3
4745             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4746             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4747           enddo
4748         enddo
4749
4750         enddo ! iint
4751       enddo ! i
4752       do i=1,nct
4753         do j=1,3
4754           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4755           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4756           gradx_scp(j,i)=expon*gradx_scp(j,i)
4757         enddo
4758       enddo
4759 !******************************************************************************
4760 !
4761 !                              N O T E !!!
4762 !
4763 ! To save time the factor EXPON has been extracted from ALL components
4764 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
4765 ! use!
4766 !
4767 !******************************************************************************
4768       return
4769       end subroutine escp
4770 !-----------------------------------------------------------------------------
4771       subroutine edis(ehpb)
4772 !
4773 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4774 !
4775 !      implicit real*8 (a-h,o-z)
4776 !      include 'DIMENSIONS'
4777 !      include 'COMMON.SBRIDGE'
4778 !      include 'COMMON.CHAIN'
4779 !      include 'COMMON.DERIV'
4780 !      include 'COMMON.VAR'
4781 !      include 'COMMON.INTERACT'
4782 !      include 'COMMON.IOUNITS'
4783       real(kind=8),dimension(3) :: ggg
4784 !el local variables
4785       integer :: i,j,ii,jj,iii,jjj,k
4786       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
4787
4788       ehpb=0.0D0
4789 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4790 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
4791       if (link_end.eq.0) return
4792       do i=link_start,link_end
4793 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4794 ! CA-CA distance used in regularization of structure.
4795         ii=ihpb(i)
4796         jj=jhpb(i)
4797 ! iii and jjj point to the residues for which the distance is assigned.
4798         if (ii.gt.nres) then
4799           iii=ii-nres
4800           jjj=jj-nres
4801         else
4802           iii=ii
4803           jjj=jj
4804         endif
4805 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4806 !     &    dhpb(i),dhpb1(i),forcon(i)
4807 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
4808 !    distance and angle dependent SS bond potential.
4809 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4810 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4811         if (.not.dyn_ss .and. i.le.nss) then
4812 ! 15/02/13 CC dynamic SSbond - additional check
4813          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. &
4814         iabs(itype(jjj)).eq.1) then
4815           call ssbond_ene(iii,jjj,eij)
4816           ehpb=ehpb+2*eij
4817 !d          write (iout,*) "eij",eij
4818          endif
4819         else
4820 ! Calculate the distance between the two points and its difference from the
4821 ! target distance.
4822         dd=dist(ii,jj)
4823         rdis=dd-dhpb(i)
4824 ! Get the force constant corresponding to this distance.
4825         waga=forcon(i)
4826 ! Calculate the contribution to energy.
4827         ehpb=ehpb+waga*rdis*rdis
4828 !
4829 ! Evaluate gradient.
4830 !
4831         fac=waga*rdis/dd
4832 !d      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4833 !d   &   ' waga=',waga,' fac=',fac
4834         do j=1,3
4835           ggg(j)=fac*(c(j,jj)-c(j,ii))
4836         enddo
4837 !d      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4838 ! If this is a SC-SC distance, we need to calculate the contributions to the
4839 ! Cartesian gradient in the SC vectors (ghpbx).
4840         if (iii.lt.ii) then
4841           do j=1,3
4842             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4843             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4844           enddo
4845         endif
4846 !grad        do j=iii,jjj-1
4847 !grad          do k=1,3
4848 !grad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4849 !grad          enddo
4850 !grad        enddo
4851         do k=1,3
4852           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4853           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4854         enddo
4855         endif
4856       enddo
4857       ehpb=0.5D0*ehpb
4858       return
4859       end subroutine edis
4860 !-----------------------------------------------------------------------------
4861       subroutine ssbond_ene(i,j,eij)
4862 !
4863 ! Calculate the distance and angle dependent SS-bond potential energy
4864 ! using a free-energy function derived based on RHF/6-31G** ab initio
4865 ! calculations of diethyl disulfide.
4866 !
4867 ! A. Liwo and U. Kozlowska, 11/24/03
4868 !
4869 !      implicit real*8 (a-h,o-z)
4870 !      include 'DIMENSIONS'
4871 !      include 'COMMON.SBRIDGE'
4872 !      include 'COMMON.CHAIN'
4873 !      include 'COMMON.DERIV'
4874 !      include 'COMMON.LOCAL'
4875 !      include 'COMMON.INTERACT'
4876 !      include 'COMMON.VAR'
4877 !      include 'COMMON.IOUNITS'
4878       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
4879 !el local variables
4880       integer :: i,j,itypi,itypj,k
4881       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
4882                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
4883                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
4884                    cosphi,ggk
4885
4886       itypi=iabs(itype(i))
4887       xi=c(1,nres+i)
4888       yi=c(2,nres+i)
4889       zi=c(3,nres+i)
4890       dxi=dc_norm(1,nres+i)
4891       dyi=dc_norm(2,nres+i)
4892       dzi=dc_norm(3,nres+i)
4893 !      dsci_inv=dsc_inv(itypi)
4894       dsci_inv=vbld_inv(nres+i)
4895       itypj=iabs(itype(j))
4896 !      dscj_inv=dsc_inv(itypj)
4897       dscj_inv=vbld_inv(nres+j)
4898       xj=c(1,nres+j)-xi
4899       yj=c(2,nres+j)-yi
4900       zj=c(3,nres+j)-zi
4901       dxj=dc_norm(1,nres+j)
4902       dyj=dc_norm(2,nres+j)
4903       dzj=dc_norm(3,nres+j)
4904       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4905       rij=dsqrt(rrij)
4906       erij(1)=xj*rij
4907       erij(2)=yj*rij
4908       erij(3)=zj*rij
4909       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4910       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4911       om12=dxi*dxj+dyi*dyj+dzi*dzj
4912       do k=1,3
4913         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4914         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4915       enddo
4916       rij=1.0d0/rij
4917       deltad=rij-d0cm
4918       deltat1=1.0d0-om1
4919       deltat2=1.0d0+om2
4920       deltat12=om2-om1+2.0d0
4921       cosphi=om12-om1*om2
4922       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
4923         +akct*deltad*deltat12 &
4924         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4925 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4926 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4927 !     &  " deltat12",deltat12," eij",eij
4928       ed=2*akcm*deltad+akct*deltat12
4929       pom1=akct*deltad
4930       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4931       eom1=-2*akth*deltat1-pom1-om2*pom2
4932       eom2= 2*akth*deltat2+pom1-om1*pom2
4933       eom12=pom2
4934       do k=1,3
4935         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4936         ghpbx(k,i)=ghpbx(k,i)-ggk &
4937                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
4938                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4939         ghpbx(k,j)=ghpbx(k,j)+ggk &
4940                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
4941                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4942         ghpbc(k,i)=ghpbc(k,i)-ggk
4943         ghpbc(k,j)=ghpbc(k,j)+ggk
4944       enddo
4945 !
4946 ! Calculate the components of the gradient in DC and X
4947 !
4948 !grad      do k=i,j-1
4949 !grad        do l=1,3
4950 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4951 !grad        enddo
4952 !grad      enddo
4953       return
4954       end subroutine ssbond_ene
4955 !-----------------------------------------------------------------------------
4956       subroutine ebond(estr)
4957 !
4958 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4959 !
4960 !      implicit real*8 (a-h,o-z)
4961 !      include 'DIMENSIONS'
4962 !      include 'COMMON.LOCAL'
4963 !      include 'COMMON.GEO'
4964 !      include 'COMMON.INTERACT'
4965 !      include 'COMMON.DERIV'
4966 !      include 'COMMON.VAR'
4967 !      include 'COMMON.CHAIN'
4968 !      include 'COMMON.IOUNITS'
4969 !      include 'COMMON.NAMES'
4970 !      include 'COMMON.FFIELD'
4971 !      include 'COMMON.CONTROL'
4972 !      include 'COMMON.SETUP'
4973       real(kind=8),dimension(3) :: u,ud
4974 !el local variables
4975       integer :: i,j,iti,nbi,k
4976       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
4977                    uprod1,uprod2
4978
4979       estr=0.0d0
4980       estr1=0.0d0
4981 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
4982 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
4983
4984       do i=ibondp_start,ibondp_end
4985         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4986         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4987 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4988 !C          do j=1,3
4989 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
4990 !C            *dc(j,i-1)/vbld(i)
4991 !C          enddo
4992 !C          if (energy_dec) write(iout,*) &
4993 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4994         diff = vbld(i)-vbldpDUM
4995         else
4996         diff = vbld(i)-vbldp0
4997         endif
4998         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
4999            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5000         estr=estr+diff*diff
5001         do j=1,3
5002           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5003         enddo
5004 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5005 !        endif
5006       enddo
5007       estr=0.5d0*AKP*estr+estr1
5008 !
5009 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5010 !
5011       do i=ibond_start,ibond_end
5012         iti=iabs(itype(i))
5013         if (iti.ne.10 .and. iti.ne.ntyp1) then
5014           nbi=nbondterm(iti)
5015           if (nbi.eq.1) then
5016             diff=vbld(i+nres)-vbldsc0(1,iti)
5017             if (energy_dec) write (iout,*) &
5018             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5019             AKSC(1,iti),AKSC(1,iti)*diff*diff
5020             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5021             do j=1,3
5022               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5023             enddo
5024           else
5025             do j=1,nbi
5026               diff=vbld(i+nres)-vbldsc0(j,iti)
5027               ud(j)=aksc(j,iti)*diff
5028               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5029             enddo
5030             uprod=u(1)
5031             do j=2,nbi
5032               uprod=uprod*u(j)
5033             enddo
5034             usum=0.0d0
5035             usumsqder=0.0d0
5036             do j=1,nbi
5037               uprod1=1.0d0
5038               uprod2=1.0d0
5039               do k=1,nbi
5040                 if (k.ne.j) then
5041                   uprod1=uprod1*u(k)
5042                   uprod2=uprod2*u(k)*u(k)
5043                 endif
5044               enddo
5045               usum=usum+uprod1
5046               usumsqder=usumsqder+ud(j)*uprod2
5047             enddo
5048             estr=estr+uprod/usum
5049             do j=1,3
5050              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5051             enddo
5052           endif
5053         endif
5054       enddo
5055       return
5056       end subroutine ebond
5057 #ifdef CRYST_THETA
5058 !-----------------------------------------------------------------------------
5059       subroutine ebend(etheta)
5060 !
5061 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5062 ! angles gamma and its derivatives in consecutive thetas and gammas.
5063 !
5064       use comm_calcthet
5065 !      implicit real*8 (a-h,o-z)
5066 !      include 'DIMENSIONS'
5067 !      include 'COMMON.LOCAL'
5068 !      include 'COMMON.GEO'
5069 !      include 'COMMON.INTERACT'
5070 !      include 'COMMON.DERIV'
5071 !      include 'COMMON.VAR'
5072 !      include 'COMMON.CHAIN'
5073 !      include 'COMMON.IOUNITS'
5074 !      include 'COMMON.NAMES'
5075 !      include 'COMMON.FFIELD'
5076 !      include 'COMMON.CONTROL'
5077 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5078 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5079 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5080 !el      integer :: it
5081 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5082 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5083 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5084 !el local variables
5085       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5086        ichir21,ichir22
5087       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5088        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5089        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5090       real(kind=8),dimension(2) :: y,z
5091
5092       delta=0.02d0*pi
5093 !      time11=dexp(-2*time)
5094 !      time12=1.0d0
5095       etheta=0.0D0
5096 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5097       do i=ithet_start,ithet_end
5098         if (itype(i-1).eq.ntyp1) cycle
5099 ! Zero the energy function and its derivative at 0 or pi.
5100         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5101         it=itype(i-1)
5102         ichir1=isign(1,itype(i-2))
5103         ichir2=isign(1,itype(i))
5104          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5105          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5106          if (itype(i-1).eq.10) then
5107           itype1=isign(10,itype(i-2))
5108           ichir11=isign(1,itype(i-2))
5109           ichir12=isign(1,itype(i-2))
5110           itype2=isign(10,itype(i))
5111           ichir21=isign(1,itype(i))
5112           ichir22=isign(1,itype(i))
5113          endif
5114
5115         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
5116 #ifdef OSF
5117           phii=phi(i)
5118           if (phii.ne.phii) phii=150.0
5119 #else
5120           phii=phi(i)
5121 #endif
5122           y(1)=dcos(phii)
5123           y(2)=dsin(phii)
5124         else
5125           y(1)=0.0D0
5126           y(2)=0.0D0
5127         endif
5128         if (i.lt.nres .and. itype(i).ne.ntyp1) then
5129 #ifdef OSF
5130           phii1=phi(i+1)
5131           if (phii1.ne.phii1) phii1=150.0
5132           phii1=pinorm(phii1)
5133           z(1)=cos(phii1)
5134 #else
5135           phii1=phi(i+1)
5136           z(1)=dcos(phii1)
5137 #endif
5138           z(2)=dsin(phii1)
5139         else
5140           z(1)=0.0D0
5141           z(2)=0.0D0
5142         endif
5143 ! Calculate the "mean" value of theta from the part of the distribution
5144 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5145 ! In following comments this theta will be referred to as t_c.
5146         thet_pred_mean=0.0d0
5147         do k=1,2
5148             athetk=athet(k,it,ichir1,ichir2)
5149             bthetk=bthet(k,it,ichir1,ichir2)
5150           if (it.eq.10) then
5151              athetk=athet(k,itype1,ichir11,ichir12)
5152              bthetk=bthet(k,itype2,ichir21,ichir22)
5153           endif
5154          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5155         enddo
5156         dthett=thet_pred_mean*ssd
5157         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5158 ! Derivatives of the "mean" values in gamma1 and gamma2.
5159         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5160                +athet(2,it,ichir1,ichir2)*y(1))*ss
5161         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5162                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5163          if (it.eq.10) then
5164         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5165              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5166         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5167                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5168          endif
5169         if (theta(i).gt.pi-delta) then
5170           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5171                E_tc0)
5172           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5173           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5174           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5175               E_theta)
5176           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5177               E_tc)
5178         else if (theta(i).lt.delta) then
5179           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5180           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5181           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5182               E_theta)
5183           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5184           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5185               E_tc)
5186         else
5187           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5188               E_theta,E_tc)
5189         endif
5190         etheta=etheta+ethetai
5191         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5192             'ebend',i,ethetai
5193         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5194         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5195         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5196       enddo
5197 ! Ufff.... We've done all this!!!
5198       return
5199       end subroutine ebend
5200 !-----------------------------------------------------------------------------
5201       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5202
5203       use comm_calcthet
5204 !      implicit real*8 (a-h,o-z)
5205 !      include 'DIMENSIONS'
5206 !      include 'COMMON.LOCAL'
5207 !      include 'COMMON.IOUNITS'
5208 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5209 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5210 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5211       integer :: i,j,k
5212       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5213 !el      integer :: it
5214 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5215 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5216 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5217 !el local variables
5218       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5219        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5220
5221 ! Calculate the contributions to both Gaussian lobes.
5222 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5223 ! The "polynomial part" of the "standard deviation" of this part of
5224 ! the distribution.
5225         sig=polthet(3,it)
5226         do j=2,0,-1
5227           sig=sig*thet_pred_mean+polthet(j,it)
5228         enddo
5229 ! Derivative of the "interior part" of the "standard deviation of the"
5230 ! gamma-dependent Gaussian lobe in t_c.
5231         sigtc=3*polthet(3,it)
5232         do j=2,1,-1
5233           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5234         enddo
5235         sigtc=sig*sigtc
5236 ! Set the parameters of both Gaussian lobes of the distribution.
5237 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5238         fac=sig*sig+sigc0(it)
5239         sigcsq=fac+fac
5240         sigc=1.0D0/sigcsq
5241 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5242         sigsqtc=-4.0D0*sigcsq*sigtc
5243 !       print *,i,sig,sigtc,sigsqtc
5244 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5245         sigtc=-sigtc/(fac*fac)
5246 ! Following variable is sigma(t_c)**(-2)
5247         sigcsq=sigcsq*sigcsq
5248         sig0i=sig0(it)
5249         sig0inv=1.0D0/sig0i**2
5250         delthec=thetai-thet_pred_mean
5251         delthe0=thetai-theta0i
5252         term1=-0.5D0*sigcsq*delthec*delthec
5253         term2=-0.5D0*sig0inv*delthe0*delthe0
5254 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5255 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5256 ! to the energy (this being the log of the distribution) at the end of energy
5257 ! term evaluation for this virtual-bond angle.
5258         if (term1.gt.term2) then
5259           termm=term1
5260           term2=dexp(term2-termm)
5261           term1=1.0d0
5262         else
5263           termm=term2
5264           term1=dexp(term1-termm)
5265           term2=1.0d0
5266         endif
5267 ! The ratio between the gamma-independent and gamma-dependent lobes of
5268 ! the distribution is a Gaussian function of thet_pred_mean too.
5269         diffak=gthet(2,it)-thet_pred_mean
5270         ratak=diffak/gthet(3,it)**2
5271         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5272 ! Let's differentiate it in thet_pred_mean NOW.
5273         aktc=ak*ratak
5274 ! Now put together the distribution terms to make complete distribution.
5275         termexp=term1+ak*term2
5276         termpre=sigc+ak*sig0i
5277 ! Contribution of the bending energy from this theta is just the -log of
5278 ! the sum of the contributions from the two lobes and the pre-exponential
5279 ! factor. Simple enough, isn't it?
5280         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5281 ! NOW the derivatives!!!
5282 ! 6/6/97 Take into account the deformation.
5283         E_theta=(delthec*sigcsq*term1 &
5284              +ak*delthe0*sig0inv*term2)/termexp
5285         E_tc=((sigtc+aktc*sig0i)/termpre &
5286             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5287              aktc*term2)/termexp)
5288       return
5289       end subroutine theteng
5290 #else
5291 !-----------------------------------------------------------------------------
5292       subroutine ebend(etheta)
5293 !
5294 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5295 ! angles gamma and its derivatives in consecutive thetas and gammas.
5296 ! ab initio-derived potentials from
5297 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5298 !
5299 !      implicit real*8 (a-h,o-z)
5300 !      include 'DIMENSIONS'
5301 !      include 'COMMON.LOCAL'
5302 !      include 'COMMON.GEO'
5303 !      include 'COMMON.INTERACT'
5304 !      include 'COMMON.DERIV'
5305 !      include 'COMMON.VAR'
5306 !      include 'COMMON.CHAIN'
5307 !      include 'COMMON.IOUNITS'
5308 !      include 'COMMON.NAMES'
5309 !      include 'COMMON.FFIELD'
5310 !      include 'COMMON.CONTROL'
5311       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5312       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5313       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5314       logical :: lprn=.false., lprn1=.false.
5315 !el local variables
5316       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5317       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5318       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl
5319
5320       etheta=0.0D0
5321       do i=ithet_start,ithet_end
5322         if (itype(i-1).eq.ntyp1) cycle
5323         if (itype(i-2).eq.ntyp1.or.itype(i).eq.ntyp1) cycle
5324         if (iabs(itype(i+1)).eq.20) iblock=2
5325         if (iabs(itype(i+1)).ne.20) iblock=1
5326         dethetai=0.0d0
5327         dephii=0.0d0
5328         dephii1=0.0d0
5329         theti2=0.5d0*theta(i)
5330         ityp2=ithetyp((itype(i-1)))
5331         do k=1,nntheterm
5332           coskt(k)=dcos(k*theti2)
5333           sinkt(k)=dsin(k*theti2)
5334         enddo
5335         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
5336 #ifdef OSF
5337           phii=phi(i)
5338           if (phii.ne.phii) phii=150.0
5339 #else
5340           phii=phi(i)
5341 #endif
5342           ityp1=ithetyp((itype(i-2)))
5343 ! propagation of chirality for glycine type
5344           do k=1,nsingle
5345             cosph1(k)=dcos(k*phii)
5346             sinph1(k)=dsin(k*phii)
5347           enddo
5348         else
5349           phii=0.0d0
5350           ityp1=ithetyp(itype(i-2))
5351           do k=1,nsingle
5352             cosph1(k)=0.0d0
5353             sinph1(k)=0.0d0
5354           enddo
5355         endif
5356         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5357 #ifdef OSF
5358           phii1=phi(i+1)
5359           if (phii1.ne.phii1) phii1=150.0
5360           phii1=pinorm(phii1)
5361 #else
5362           phii1=phi(i+1)
5363 #endif
5364           ityp3=ithetyp((itype(i)))
5365           do k=1,nsingle
5366             cosph2(k)=dcos(k*phii1)
5367             sinph2(k)=dsin(k*phii1)
5368           enddo
5369         else
5370           phii1=0.0d0
5371           ityp3=ithetyp(itype(i))
5372           do k=1,nsingle
5373             cosph2(k)=0.0d0
5374             sinph2(k)=0.0d0
5375           enddo
5376         endif
5377         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5378         do k=1,ndouble
5379           do l=1,k-1
5380             ccl=cosph1(l)*cosph2(k-l)
5381             ssl=sinph1(l)*sinph2(k-l)
5382             scl=sinph1(l)*cosph2(k-l)
5383             csl=cosph1(l)*sinph2(k-l)
5384             cosph1ph2(l,k)=ccl-ssl
5385             cosph1ph2(k,l)=ccl+ssl
5386             sinph1ph2(l,k)=scl+csl
5387             sinph1ph2(k,l)=scl-csl
5388           enddo
5389         enddo
5390         if (lprn) then
5391         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5392           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5393         write (iout,*) "coskt and sinkt"
5394         do k=1,nntheterm
5395           write (iout,*) k,coskt(k),sinkt(k)
5396         enddo
5397         endif
5398         do k=1,ntheterm
5399           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5400           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5401             *coskt(k)
5402           if (lprn) &
5403           write (iout,*) "k",k,&
5404            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5405            " ethetai",ethetai
5406         enddo
5407         if (lprn) then
5408         write (iout,*) "cosph and sinph"
5409         do k=1,nsingle
5410           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5411         enddo
5412         write (iout,*) "cosph1ph2 and sinph2ph2"
5413         do k=2,ndouble
5414           do l=1,k-1
5415             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5416                sinph1ph2(l,k),sinph1ph2(k,l)
5417           enddo
5418         enddo
5419         write(iout,*) "ethetai",ethetai
5420         endif
5421         do m=1,ntheterm2
5422           do k=1,nsingle
5423             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5424                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5425                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5426                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5427             ethetai=ethetai+sinkt(m)*aux
5428             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5429             dephii=dephii+k*sinkt(m)* &
5430                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5431                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5432             dephii1=dephii1+k*sinkt(m)* &
5433                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5434                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5435             if (lprn) &
5436             write (iout,*) "m",m," k",k," bbthet", &
5437                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5438                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5439                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5440                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5441           enddo
5442         enddo
5443         if (lprn) &
5444         write(iout,*) "ethetai",ethetai
5445         do m=1,ntheterm3
5446           do k=2,ndouble
5447             do l=1,k-1
5448               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5449                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5450                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5451                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5452               ethetai=ethetai+sinkt(m)*aux
5453               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5454               dephii=dephii+l*sinkt(m)* &
5455                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5456                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5457                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5458                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5459               dephii1=dephii1+(k-l)*sinkt(m)* &
5460                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5461                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5462                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5463                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5464               if (lprn) then
5465               write (iout,*) "m",m," k",k," l",l," ffthet",&
5466                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5467                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5468                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5469                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5470                   " ethetai",ethetai
5471               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5472                   cosph1ph2(k,l)*sinkt(m),&
5473                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5474               endif
5475             enddo
5476           enddo
5477         enddo
5478 10      continue
5479 !        lprn1=.true.
5480         if (lprn1) &
5481           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5482          i,theta(i)*rad2deg,phii*rad2deg,&
5483          phii1*rad2deg,ethetai
5484 !        lprn1=.false.
5485         etheta=etheta+ethetai
5486         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5487                                     'ebend',i,ethetai
5488         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5489         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5490         gloc(nphi+i-2,icg)=wang*dethetai
5491       enddo
5492       return
5493       end subroutine ebend
5494 #endif
5495 #ifdef CRYST_SC
5496 !-----------------------------------------------------------------------------
5497       subroutine esc(escloc)
5498 ! Calculate the local energy of a side chain and its derivatives in the
5499 ! corresponding virtual-bond valence angles THETA and the spherical angles
5500 ! ALPHA and OMEGA.
5501 !
5502       use comm_sccalc
5503 !      implicit real*8 (a-h,o-z)
5504 !      include 'DIMENSIONS'
5505 !      include 'COMMON.GEO'
5506 !      include 'COMMON.LOCAL'
5507 !      include 'COMMON.VAR'
5508 !      include 'COMMON.INTERACT'
5509 !      include 'COMMON.DERIV'
5510 !      include 'COMMON.CHAIN'
5511 !      include 'COMMON.IOUNITS'
5512 !      include 'COMMON.NAMES'
5513 !      include 'COMMON.FFIELD'
5514 !      include 'COMMON.CONTROL'
5515       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5516          ddersc0,ddummy,xtemp,temp
5517 !el      real(kind=8) :: time11,time12,time112,theti
5518       real(kind=8) :: escloc,delta
5519 !el      integer :: it,nlobit
5520 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5521 !el local variables
5522       integer :: i,k
5523       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5524        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5525       delta=0.02d0*pi
5526       escloc=0.0D0
5527 !     write (iout,'(a)') 'ESC'
5528       do i=loc_start,loc_end
5529         it=itype(i)
5530         if (it.eq.ntyp1) cycle
5531         if (it.eq.10) goto 1
5532         nlobit=nlob(iabs(it))
5533 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5534 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5535         theti=theta(i+1)-pipol
5536         x(1)=dtan(theti)
5537         x(2)=alph(i)
5538         x(3)=omeg(i)
5539
5540         if (x(2).gt.pi-delta) then
5541           xtemp(1)=x(1)
5542           xtemp(2)=pi-delta
5543           xtemp(3)=x(3)
5544           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5545           xtemp(2)=pi
5546           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5547           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5548               escloci,dersc(2))
5549           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5550               ddersc0(1),dersc(1))
5551           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5552               ddersc0(3),dersc(3))
5553           xtemp(2)=pi-delta
5554           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5555           xtemp(2)=pi
5556           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5557           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5558                   dersc0(2),esclocbi,dersc02)
5559           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5560                   dersc12,dersc01)
5561           call splinthet(x(2),0.5d0*delta,ss,ssd)
5562           dersc0(1)=dersc01
5563           dersc0(2)=dersc02
5564           dersc0(3)=0.0d0
5565           do k=1,3
5566             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5567           enddo
5568           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5569 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5570 !    &             esclocbi,ss,ssd
5571           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5572 !         escloci=esclocbi
5573 !         write (iout,*) escloci
5574         else if (x(2).lt.delta) then
5575           xtemp(1)=x(1)
5576           xtemp(2)=delta
5577           xtemp(3)=x(3)
5578           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5579           xtemp(2)=0.0d0
5580           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5581           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
5582               escloci,dersc(2))
5583           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5584               ddersc0(1),dersc(1))
5585           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
5586               ddersc0(3),dersc(3))
5587           xtemp(2)=delta
5588           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5589           xtemp(2)=0.0d0
5590           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5591           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
5592                   dersc0(2),esclocbi,dersc02)
5593           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5594                   dersc12,dersc01)
5595           dersc0(1)=dersc01
5596           dersc0(2)=dersc02
5597           dersc0(3)=0.0d0
5598           call splinthet(x(2),0.5d0*delta,ss,ssd)
5599           do k=1,3
5600             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5601           enddo
5602           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5603 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5604 !    &             esclocbi,ss,ssd
5605           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5606 !         write (iout,*) escloci
5607         else
5608           call enesc(x,escloci,dersc,ddummy,.false.)
5609         endif
5610
5611         escloc=escloc+escloci
5612         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5613            'escloc',i,escloci
5614 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5615
5616         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
5617          wscloc*dersc(1)
5618         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5619         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5620     1   continue
5621       enddo
5622       return
5623       end subroutine esc
5624 !-----------------------------------------------------------------------------
5625       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5626
5627       use comm_sccalc
5628 !      implicit real*8 (a-h,o-z)
5629 !      include 'DIMENSIONS'
5630 !      include 'COMMON.GEO'
5631 !      include 'COMMON.LOCAL'
5632 !      include 'COMMON.IOUNITS'
5633 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5634       real(kind=8),dimension(3) :: x,z,dersc,ddersc
5635       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
5636       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
5637       real(kind=8) :: escloci
5638       logical :: mixed
5639 !el local variables
5640       integer :: j,iii,l,k !el,it,nlobit
5641       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
5642 !el       time11,time12,time112
5643 !       write (iout,*) 'it=',it,' nlobit=',nlobit
5644         escloc_i=0.0D0
5645         do j=1,3
5646           dersc(j)=0.0D0
5647           if (mixed) ddersc(j)=0.0d0
5648         enddo
5649         x3=x(3)
5650
5651 ! Because of periodicity of the dependence of the SC energy in omega we have
5652 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5653 ! To avoid underflows, first compute & store the exponents.
5654
5655         do iii=-1,1
5656
5657           x(3)=x3+iii*dwapi
5658
5659           do j=1,nlobit
5660             do k=1,3
5661               z(k)=x(k)-censc(k,j,it)
5662             enddo
5663             do k=1,3
5664               Axk=0.0D0
5665               do l=1,3
5666                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5667               enddo
5668               Ax(k,j,iii)=Axk
5669             enddo
5670             expfac=0.0D0
5671             do k=1,3
5672               expfac=expfac+Ax(k,j,iii)*z(k)
5673             enddo
5674             contr(j,iii)=expfac
5675           enddo ! j
5676
5677         enddo ! iii
5678
5679         x(3)=x3
5680 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5681 ! subsequent NaNs and INFs in energy calculation.
5682 ! Find the largest exponent
5683         emin=contr(1,-1)
5684         do iii=-1,1
5685           do j=1,nlobit
5686             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5687           enddo
5688         enddo
5689         emin=0.5D0*emin
5690 !d      print *,'it=',it,' emin=',emin
5691
5692 ! Compute the contribution to SC energy and derivatives
5693         do iii=-1,1
5694
5695           do j=1,nlobit
5696 #ifdef OSF
5697             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5698             if(adexp.ne.adexp) adexp=1.0
5699             expfac=dexp(adexp)
5700 #else
5701             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5702 #endif
5703 !d          print *,'j=',j,' expfac=',expfac
5704             escloc_i=escloc_i+expfac
5705             do k=1,3
5706               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5707             enddo
5708             if (mixed) then
5709               do k=1,3,2
5710                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
5711                   +gaussc(k,2,j,it))*expfac
5712               enddo
5713             endif
5714           enddo
5715
5716         enddo ! iii
5717
5718         dersc(1)=dersc(1)/cos(theti)**2
5719         ddersc(1)=ddersc(1)/cos(theti)**2
5720         ddersc(3)=ddersc(3)
5721
5722         escloci=-(dlog(escloc_i)-emin)
5723         do j=1,3
5724           dersc(j)=dersc(j)/escloc_i
5725         enddo
5726         if (mixed) then
5727           do j=1,3,2
5728             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5729           enddo
5730         endif
5731       return
5732       end subroutine enesc
5733 !-----------------------------------------------------------------------------
5734       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5735
5736       use comm_sccalc
5737 !      implicit real*8 (a-h,o-z)
5738 !      include 'DIMENSIONS'
5739 !      include 'COMMON.GEO'
5740 !      include 'COMMON.LOCAL'
5741 !      include 'COMMON.IOUNITS'
5742 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5743       real(kind=8),dimension(3) :: x,z,dersc
5744       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
5745       real(kind=8),dimension(nlobit) :: contr !(maxlob)
5746       real(kind=8) :: escloci,dersc12,emin
5747       logical :: mixed
5748 !el local varables
5749       integer :: j,k,l !el,it,nlobit
5750       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
5751
5752       escloc_i=0.0D0
5753
5754       do j=1,3
5755         dersc(j)=0.0D0
5756       enddo
5757
5758       do j=1,nlobit
5759         do k=1,2
5760           z(k)=x(k)-censc(k,j,it)
5761         enddo
5762         z(3)=dwapi
5763         do k=1,3
5764           Axk=0.0D0
5765           do l=1,3
5766             Axk=Axk+gaussc(l,k,j,it)*z(l)
5767           enddo
5768           Ax(k,j)=Axk
5769         enddo
5770         expfac=0.0D0
5771         do k=1,3
5772           expfac=expfac+Ax(k,j)*z(k)
5773         enddo
5774         contr(j)=expfac
5775       enddo ! j
5776
5777 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5778 ! subsequent NaNs and INFs in energy calculation.
5779 ! Find the largest exponent
5780       emin=contr(1)
5781       do j=1,nlobit
5782         if (emin.gt.contr(j)) emin=contr(j)
5783       enddo
5784       emin=0.5D0*emin
5785
5786 ! Compute the contribution to SC energy and derivatives
5787
5788       dersc12=0.0d0
5789       do j=1,nlobit
5790         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5791         escloc_i=escloc_i+expfac
5792         do k=1,2
5793           dersc(k)=dersc(k)+Ax(k,j)*expfac
5794         enddo
5795         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
5796                   +gaussc(1,2,j,it))*expfac
5797         dersc(3)=0.0d0
5798       enddo
5799
5800       dersc(1)=dersc(1)/cos(theti)**2
5801       dersc12=dersc12/cos(theti)**2
5802       escloci=-(dlog(escloc_i)-emin)
5803       do j=1,2
5804         dersc(j)=dersc(j)/escloc_i
5805       enddo
5806       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5807       return
5808       end subroutine enesc_bound
5809 #else
5810 !-----------------------------------------------------------------------------
5811       subroutine esc(escloc)
5812 ! Calculate the local energy of a side chain and its derivatives in the
5813 ! corresponding virtual-bond valence angles THETA and the spherical angles
5814 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
5815 ! added by Urszula Kozlowska. 07/11/2007
5816 !
5817       use comm_sccalc
5818 !      implicit real*8 (a-h,o-z)
5819 !      include 'DIMENSIONS'
5820 !      include 'COMMON.GEO'
5821 !      include 'COMMON.LOCAL'
5822 !      include 'COMMON.VAR'
5823 !      include 'COMMON.SCROT'
5824 !      include 'COMMON.INTERACT'
5825 !      include 'COMMON.DERIV'
5826 !      include 'COMMON.CHAIN'
5827 !      include 'COMMON.IOUNITS'
5828 !      include 'COMMON.NAMES'
5829 !      include 'COMMON.FFIELD'
5830 !      include 'COMMON.CONTROL'
5831 !      include 'COMMON.VECTORS'
5832       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
5833       real(kind=8),dimension(65) :: x
5834       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
5835          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
5836       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
5837       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
5838          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
5839 !el local variables
5840       integer :: i,j,k !el,it,nlobit
5841       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
5842 !el      real(kind=8) :: time11,time12,time112,theti
5843 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5844       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
5845                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
5846                    sumene1x,sumene2x,sumene3x,sumene4x,&
5847                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
5848                    cosfac2xx,sinfac2yy
5849 #ifdef DEBUG
5850       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
5851                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
5852                    de_dt_num
5853 #endif
5854 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
5855
5856       delta=0.02d0*pi
5857       escloc=0.0D0
5858       do i=loc_start,loc_end
5859         if (itype(i).eq.ntyp1) cycle
5860         costtab(i+1) =dcos(theta(i+1))
5861         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5862         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5863         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5864         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5865         cosfac=dsqrt(cosfac2)
5866         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5867         sinfac=dsqrt(sinfac2)
5868         it=iabs(itype(i))
5869         if (it.eq.10) goto 1
5870 !
5871 !  Compute the axes of tghe local cartesian coordinates system; store in
5872 !   x_prime, y_prime and z_prime
5873 !
5874         do j=1,3
5875           x_prime(j) = 0.00
5876           y_prime(j) = 0.00
5877           z_prime(j) = 0.00
5878         enddo
5879 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5880 !     &   dc_norm(3,i+nres)
5881         do j = 1,3
5882           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5883           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5884         enddo
5885         do j = 1,3
5886           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5887         enddo
5888 !       write (2,*) "i",i
5889 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
5890 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
5891 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
5892 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5893 !      & " xy",scalar(x_prime(1),y_prime(1)),
5894 !      & " xz",scalar(x_prime(1),z_prime(1)),
5895 !      & " yy",scalar(y_prime(1),y_prime(1)),
5896 !      & " yz",scalar(y_prime(1),z_prime(1)),
5897 !      & " zz",scalar(z_prime(1),z_prime(1))
5898 !
5899 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5900 ! to local coordinate system. Store in xx, yy, zz.
5901 !
5902         xx=0.0d0
5903         yy=0.0d0
5904         zz=0.0d0
5905         do j = 1,3
5906           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5907           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5908           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5909         enddo
5910
5911         xxtab(i)=xx
5912         yytab(i)=yy
5913         zztab(i)=zz
5914 !
5915 ! Compute the energy of the ith side cbain
5916 !
5917 !        write (2,*) "xx",xx," yy",yy," zz",zz
5918         it=iabs(itype(i))
5919         do j = 1,65
5920           x(j) = sc_parmin(j,it)
5921         enddo
5922 #ifdef CHECK_COORD
5923 !c diagnostics - remove later
5924         xx1 = dcos(alph(2))
5925         yy1 = dsin(alph(2))*dcos(omeg(2))
5926         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5927         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
5928           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
5929           xx1,yy1,zz1
5930 !,"  --- ", xx_w,yy_w,zz_w
5931 ! end diagnostics
5932 #endif
5933         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
5934          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
5935          + x(10)*yy*zz
5936         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
5937          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
5938          + x(20)*yy*zz
5939         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
5940          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
5941          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
5942          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
5943          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
5944          +x(40)*xx*yy*zz
5945         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
5946          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
5947          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
5948          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
5949          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
5950          +x(60)*xx*yy*zz
5951         dsc_i   = 0.743d0+x(61)
5952         dp2_i   = 1.9d0+x(62)
5953         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5954                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5955         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
5956                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5957         s1=(1+x(63))/(0.1d0 + dscp1)
5958         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5959         s2=(1+x(65))/(0.1d0 + dscp2)
5960         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5961         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
5962       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5963 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5964 !     &   sumene4,
5965 !     &   dscp1,dscp2,sumene
5966 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5967         escloc = escloc + sumene
5968 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5969 !     & ,zz,xx,yy
5970 !#define DEBUG
5971 #ifdef DEBUG
5972 !
5973 ! This section to check the numerical derivatives of the energy of ith side
5974 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5975 ! #define DEBUG in the code to turn it on.
5976 !
5977         write (2,*) "sumene               =",sumene
5978         aincr=1.0d-7
5979         xxsave=xx
5980         xx=xx+aincr
5981         write (2,*) xx,yy,zz
5982         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5983         de_dxx_num=(sumenep-sumene)/aincr
5984         xx=xxsave
5985         write (2,*) "xx+ sumene from enesc=",sumenep
5986         yysave=yy
5987         yy=yy+aincr
5988         write (2,*) xx,yy,zz
5989         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5990         de_dyy_num=(sumenep-sumene)/aincr
5991         yy=yysave
5992         write (2,*) "yy+ sumene from enesc=",sumenep
5993         zzsave=zz
5994         zz=zz+aincr
5995         write (2,*) xx,yy,zz
5996         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5997         de_dzz_num=(sumenep-sumene)/aincr
5998         zz=zzsave
5999         write (2,*) "zz+ sumene from enesc=",sumenep
6000         costsave=cost2tab(i+1)
6001         sintsave=sint2tab(i+1)
6002         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6003         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6004         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6005         de_dt_num=(sumenep-sumene)/aincr
6006         write (2,*) " t+ sumene from enesc=",sumenep
6007         cost2tab(i+1)=costsave
6008         sint2tab(i+1)=sintsave
6009 ! End of diagnostics section.
6010 #endif
6011 !
6012 ! Compute the gradient of esc
6013 !
6014 !        zz=zz*dsign(1.0,dfloat(itype(i)))
6015         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6016         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6017         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6018         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6019         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6020         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6021         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6022         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6023         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6024            *(pom_s1/dscp1+pom_s16*dscp1**4)
6025         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6026            *(pom_s2/dscp2+pom_s26*dscp2**4)
6027         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6028         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6029         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6030         +x(40)*yy*zz
6031         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6032         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6033         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6034         +x(60)*yy*zz
6035         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6036               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6037               +(pom1+pom2)*pom_dx
6038 #ifdef DEBUG
6039         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6040 #endif
6041 !
6042         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6043         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6044         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6045         +x(40)*xx*zz
6046         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6047         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6048         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6049         +x(59)*zz**2 +x(60)*xx*zz
6050         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6051               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6052               +(pom1-pom2)*pom_dy
6053 #ifdef DEBUG
6054         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6055 #endif
6056 !
6057         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6058         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6059         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6060         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6061         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6062         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6063         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6064         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6065 #ifdef DEBUG
6066         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6067 #endif
6068 !
6069         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6070         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6071         +pom1*pom_dt1+pom2*pom_dt2
6072 #ifdef DEBUG
6073         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6074 #endif
6075 !
6076 !
6077        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6078        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6079        cosfac2xx=cosfac2*xx
6080        sinfac2yy=sinfac2*yy
6081        do k = 1,3
6082          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6083             vbld_inv(i+1)
6084          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6085             vbld_inv(i)
6086          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6087          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6088 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6089 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6090 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6091 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6092          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6093          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6094          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6095          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6096          dZZ_Ci1(k)=0.0d0
6097          dZZ_Ci(k)=0.0d0
6098          do j=1,3
6099            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6100            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6101            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6102            *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6103          enddo
6104
6105          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6106          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6107          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6108          (z_prime(k)-zz*dC_norm(k,i+nres))
6109 !
6110          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6111          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6112        enddo
6113
6114        do k=1,3
6115          dXX_Ctab(k,i)=dXX_Ci(k)
6116          dXX_C1tab(k,i)=dXX_Ci1(k)
6117          dYY_Ctab(k,i)=dYY_Ci(k)
6118          dYY_C1tab(k,i)=dYY_Ci1(k)
6119          dZZ_Ctab(k,i)=dZZ_Ci(k)
6120          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6121          dXX_XYZtab(k,i)=dXX_XYZ(k)
6122          dYY_XYZtab(k,i)=dYY_XYZ(k)
6123          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6124        enddo
6125
6126        do k = 1,3
6127 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6128 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6129 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6130 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6131 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6132 !     &    dt_dci(k)
6133 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6134 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6135          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6136           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6137          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6138           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6139          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6140           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6141        enddo
6142 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6143 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6144
6145 ! to check gradient call subroutine check_grad
6146
6147     1 continue
6148       enddo
6149       return
6150       end subroutine esc
6151 !-----------------------------------------------------------------------------
6152       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6153 !      implicit none
6154       real(kind=8),dimension(65) :: x
6155       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6156         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6157
6158       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6159         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6160         + x(10)*yy*zz
6161       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6162         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6163         + x(20)*yy*zz
6164       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6165         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6166         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6167         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6168         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6169         +x(40)*xx*yy*zz
6170       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6171         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6172         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6173         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6174         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6175         +x(60)*xx*yy*zz
6176       dsc_i   = 0.743d0+x(61)
6177       dp2_i   = 1.9d0+x(62)
6178       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6179                 *(xx*cost2+yy*sint2))
6180       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6181                 *(xx*cost2-yy*sint2))
6182       s1=(1+x(63))/(0.1d0 + dscp1)
6183       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6184       s2=(1+x(65))/(0.1d0 + dscp2)
6185       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6186       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6187        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6188       enesc=sumene
6189       return
6190       end function enesc
6191 #endif
6192 !-----------------------------------------------------------------------------
6193       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6194 !
6195 ! This procedure calculates two-body contact function g(rij) and its derivative:
6196 !
6197 !           eps0ij                                     !       x < -1
6198 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6199 !            0                                         !       x > 1
6200 !
6201 ! where x=(rij-r0ij)/delta
6202 !
6203 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6204 !
6205 !      implicit none
6206       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6207       real(kind=8) :: x,x2,x4,delta
6208 !     delta=0.02D0*r0ij
6209 !      delta=0.2D0*r0ij
6210       x=(rij-r0ij)/delta
6211       if (x.lt.-1.0D0) then
6212         fcont=eps0ij
6213         fprimcont=0.0D0
6214       else if (x.le.1.0D0) then
6215         x2=x*x
6216         x4=x2*x2
6217         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6218         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6219       else
6220         fcont=0.0D0
6221         fprimcont=0.0D0
6222       endif
6223       return
6224       end subroutine gcont
6225 !-----------------------------------------------------------------------------
6226       subroutine splinthet(theti,delta,ss,ssder)
6227 !      implicit real*8 (a-h,o-z)
6228 !      include 'DIMENSIONS'
6229 !      include 'COMMON.VAR'
6230 !      include 'COMMON.GEO'
6231       real(kind=8) :: theti,delta,ss,ssder
6232       real(kind=8) :: thetup,thetlow
6233       thetup=pi-delta
6234       thetlow=delta
6235       if (theti.gt.pipol) then
6236         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6237       else
6238         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6239         ssder=-ssder
6240       endif
6241       return
6242       end subroutine splinthet
6243 !-----------------------------------------------------------------------------
6244       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6245 !      implicit none
6246       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6247       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6248       a1=fprim0*delta/(f1-f0)
6249       a2=3.0d0-2.0d0*a1
6250       a3=a1-2.0d0
6251       ksi=(x-x0)/delta
6252       ksi2=ksi*ksi
6253       ksi3=ksi2*ksi
6254       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6255       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6256       return
6257       end subroutine spline1
6258 !-----------------------------------------------------------------------------
6259       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6260 !      implicit none
6261       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6262       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6263       ksi=(x-x0)/delta
6264       ksi2=ksi*ksi
6265       ksi3=ksi2*ksi
6266       a1=fprim0x*delta
6267       a2=3*(f1x-f0x)-2*fprim0x*delta
6268       a3=fprim0x*delta-2*(f1x-f0x)
6269       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6270       return
6271       end subroutine spline2
6272 !-----------------------------------------------------------------------------
6273 #ifdef CRYST_TOR
6274 !-----------------------------------------------------------------------------
6275       subroutine etor(etors,edihcnstr)
6276 !      implicit real*8 (a-h,o-z)
6277 !      include 'DIMENSIONS'
6278 !      include 'COMMON.VAR'
6279 !      include 'COMMON.GEO'
6280 !      include 'COMMON.LOCAL'
6281 !      include 'COMMON.TORSION'
6282 !      include 'COMMON.INTERACT'
6283 !      include 'COMMON.DERIV'
6284 !      include 'COMMON.CHAIN'
6285 !      include 'COMMON.NAMES'
6286 !      include 'COMMON.IOUNITS'
6287 !      include 'COMMON.FFIELD'
6288 !      include 'COMMON.TORCNSTR'
6289 !      include 'COMMON.CONTROL'
6290       real(kind=8) :: etors,edihcnstr
6291       logical :: lprn
6292 !el local variables
6293       integer :: i,j,
6294       real(kind=8) :: phii,fac,etors_ii
6295
6296 ! Set lprn=.true. for debugging
6297       lprn=.false.
6298 !      lprn=.true.
6299       etors=0.0D0
6300       do i=iphi_start,iphi_end
6301       etors_ii=0.0D0
6302         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 &
6303             .or. itype(i).eq.ntyp1) cycle
6304         itori=itortyp(itype(i-2))
6305         itori1=itortyp(itype(i-1))
6306         phii=phi(i)
6307         gloci=0.0D0
6308 ! Proline-Proline pair is a special case...
6309         if (itori.eq.3 .and. itori1.eq.3) then
6310           if (phii.gt.-dwapi3) then
6311             cosphi=dcos(3*phii)
6312             fac=1.0D0/(1.0D0-cosphi)
6313             etorsi=v1(1,3,3)*fac
6314             etorsi=etorsi+etorsi
6315             etors=etors+etorsi-v1(1,3,3)
6316             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6317             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6318           endif
6319           do j=1,3
6320             v1ij=v1(j+1,itori,itori1)
6321             v2ij=v2(j+1,itori,itori1)
6322             cosphi=dcos(j*phii)
6323             sinphi=dsin(j*phii)
6324             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6325             if (energy_dec) etors_ii=etors_ii+ &
6326                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6327             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6328           enddo
6329         else
6330           do j=1,nterm_old
6331             v1ij=v1(j,itori,itori1)
6332             v2ij=v2(j,itori,itori1)
6333             cosphi=dcos(j*phii)
6334             sinphi=dsin(j*phii)
6335             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6336             if (energy_dec) etors_ii=etors_ii+ &
6337                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6338             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6339           enddo
6340         endif
6341         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6342              'etor',i,etors_ii
6343         if (lprn) &
6344         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6345         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
6346         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6347         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6348 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6349       enddo
6350 ! 6/20/98 - dihedral angle constraints
6351       edihcnstr=0.0d0
6352       do i=1,ndih_constr
6353         itori=idih_constr(i)
6354         phii=phi(itori)
6355         difi=phii-phi0(i)
6356         if (difi.gt.drange(i)) then
6357           difi=difi-drange(i)
6358           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6359           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6360         else if (difi.lt.-drange(i)) then
6361           difi=difi+drange(i)
6362           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6363           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6364         endif
6365 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6366 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6367       enddo
6368 !      write (iout,*) 'edihcnstr',edihcnstr
6369       return
6370       end subroutine etor
6371 !-----------------------------------------------------------------------------
6372       subroutine etor_d(etors_d)
6373       real(kind=8) :: etors_d
6374       etors_d=0.0d0
6375       return
6376       end subroutine etor_d
6377 #else
6378 !-----------------------------------------------------------------------------
6379       subroutine etor(etors,edihcnstr)
6380 !      implicit real*8 (a-h,o-z)
6381 !      include 'DIMENSIONS'
6382 !      include 'COMMON.VAR'
6383 !      include 'COMMON.GEO'
6384 !      include 'COMMON.LOCAL'
6385 !      include 'COMMON.TORSION'
6386 !      include 'COMMON.INTERACT'
6387 !      include 'COMMON.DERIV'
6388 !      include 'COMMON.CHAIN'
6389 !      include 'COMMON.NAMES'
6390 !      include 'COMMON.IOUNITS'
6391 !      include 'COMMON.FFIELD'
6392 !      include 'COMMON.TORCNSTR'
6393 !      include 'COMMON.CONTROL'
6394       real(kind=8) :: etors,edihcnstr
6395       logical :: lprn
6396 !el local variables
6397       integer :: i,j,iblock,itori,itori1
6398       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6399                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6400 ! Set lprn=.true. for debugging
6401       lprn=.false.
6402 !     lprn=.true.
6403       etors=0.0D0
6404       do i=iphi_start,iphi_end
6405         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
6406              .or. itype(i-3).eq.ntyp1 &
6407              .or. itype(i).eq.ntyp1) cycle
6408         etors_ii=0.0D0
6409          if (iabs(itype(i)).eq.20) then
6410          iblock=2
6411          else
6412          iblock=1
6413          endif
6414         itori=itortyp(itype(i-2))
6415         itori1=itortyp(itype(i-1))
6416         phii=phi(i)
6417         gloci=0.0D0
6418 ! Regular cosine and sine terms
6419         do j=1,nterm(itori,itori1,iblock)
6420           v1ij=v1(j,itori,itori1,iblock)
6421           v2ij=v2(j,itori,itori1,iblock)
6422           cosphi=dcos(j*phii)
6423           sinphi=dsin(j*phii)
6424           etors=etors+v1ij*cosphi+v2ij*sinphi
6425           if (energy_dec) etors_ii=etors_ii+ &
6426                      v1ij*cosphi+v2ij*sinphi
6427           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6428         enddo
6429 ! Lorentz terms
6430 !                         v1
6431 !  E = SUM ----------------------------------- - v1
6432 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6433 !
6434         cosphi=dcos(0.5d0*phii)
6435         sinphi=dsin(0.5d0*phii)
6436         do j=1,nlor(itori,itori1,iblock)
6437           vl1ij=vlor1(j,itori,itori1)
6438           vl2ij=vlor2(j,itori,itori1)
6439           vl3ij=vlor3(j,itori,itori1)
6440           pom=vl2ij*cosphi+vl3ij*sinphi
6441           pom1=1.0d0/(pom*pom+1.0d0)
6442           etors=etors+vl1ij*pom1
6443           if (energy_dec) etors_ii=etors_ii+ &
6444                      vl1ij*pom1
6445           pom=-pom*pom1*pom1
6446           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6447         enddo
6448 ! Subtract the constant term
6449         etors=etors-v0(itori,itori1,iblock)
6450           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6451                'etor',i,etors_ii-v0(itori,itori1,iblock)
6452         if (lprn) &
6453         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6454         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,&
6455         (v1(j,itori,itori1,iblock),j=1,6),&
6456         (v2(j,itori,itori1,iblock),j=1,6)
6457         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6458 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6459       enddo
6460 ! 6/20/98 - dihedral angle constraints
6461       edihcnstr=0.0d0
6462 !      do i=1,ndih_constr
6463       do i=idihconstr_start,idihconstr_end
6464         itori=idih_constr(i)
6465         phii=phi(itori)
6466         difi=pinorm(phii-phi0(i))
6467         if (difi.gt.drange(i)) then
6468           difi=difi-drange(i)
6469           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6470           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6471         else if (difi.lt.-drange(i)) then
6472           difi=difi+drange(i)
6473           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6474           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6475         else
6476           difi=0.0
6477         endif
6478 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6479 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6480 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6481       enddo
6482 !d       write (iout,*) 'edihcnstr',edihcnstr
6483       return
6484       end subroutine etor
6485 !-----------------------------------------------------------------------------
6486       subroutine etor_d(etors_d)
6487 ! 6/23/01 Compute double torsional energy
6488 !      implicit real*8 (a-h,o-z)
6489 !      include 'DIMENSIONS'
6490 !      include 'COMMON.VAR'
6491 !      include 'COMMON.GEO'
6492 !      include 'COMMON.LOCAL'
6493 !      include 'COMMON.TORSION'
6494 !      include 'COMMON.INTERACT'
6495 !      include 'COMMON.DERIV'
6496 !      include 'COMMON.CHAIN'
6497 !      include 'COMMON.NAMES'
6498 !      include 'COMMON.IOUNITS'
6499 !      include 'COMMON.FFIELD'
6500 !      include 'COMMON.TORCNSTR'
6501       real(kind=8) :: etors_d,etors_d_ii
6502       logical :: lprn
6503 !el local variables
6504       integer :: i,j,k,l,itori,itori1,itori2,iblock
6505       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6506                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6507                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6508                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6509 ! Set lprn=.true. for debugging
6510       lprn=.false.
6511 !     lprn=.true.
6512       etors_d=0.0D0
6513 !      write(iout,*) "a tu??"
6514       do i=iphid_start,iphid_end
6515         etors_d_ii=0.0D0
6516         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
6517             .or. itype(i-3).eq.ntyp1 &
6518             .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
6519         itori=itortyp(itype(i-2))
6520         itori1=itortyp(itype(i-1))
6521         itori2=itortyp(itype(i))
6522         phii=phi(i)
6523         phii1=phi(i+1)
6524         gloci1=0.0D0
6525         gloci2=0.0D0
6526         iblock=1
6527         if (iabs(itype(i+1)).eq.20) iblock=2
6528
6529 ! Regular cosine and sine terms
6530         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6531           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6532           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6533           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6534           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6535           cosphi1=dcos(j*phii)
6536           sinphi1=dsin(j*phii)
6537           cosphi2=dcos(j*phii1)
6538           sinphi2=dsin(j*phii1)
6539           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6540            v2cij*cosphi2+v2sij*sinphi2
6541           if (energy_dec) etors_d_ii=etors_d_ii+ &
6542            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6543           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6544           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6545         enddo
6546         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6547           do l=1,k-1
6548             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6549             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6550             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6551             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6552             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6553             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6554             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6555             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6556             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6557               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6558             if (energy_dec) etors_d_ii=etors_d_ii+ &
6559               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6560               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6561             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6562               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6563             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6564               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6565           enddo
6566         enddo
6567         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6568                             'etor_d',i,etors_d_ii
6569         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6570         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6571       enddo
6572       return
6573       end subroutine etor_d
6574 #endif
6575 !-----------------------------------------------------------------------------
6576       subroutine eback_sc_corr(esccor)
6577 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
6578 !        conformational states; temporarily implemented as differences
6579 !        between UNRES torsional potentials (dependent on three types of
6580 !        residues) and the torsional potentials dependent on all 20 types
6581 !        of residues computed from AM1  energy surfaces of terminally-blocked
6582 !        amino-acid residues.
6583 !      implicit real*8 (a-h,o-z)
6584 !      include 'DIMENSIONS'
6585 !      include 'COMMON.VAR'
6586 !      include 'COMMON.GEO'
6587 !      include 'COMMON.LOCAL'
6588 !      include 'COMMON.TORSION'
6589 !      include 'COMMON.SCCOR'
6590 !      include 'COMMON.INTERACT'
6591 !      include 'COMMON.DERIV'
6592 !      include 'COMMON.CHAIN'
6593 !      include 'COMMON.NAMES'
6594 !      include 'COMMON.IOUNITS'
6595 !      include 'COMMON.FFIELD'
6596 !      include 'COMMON.CONTROL'
6597       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
6598                    cosphi,sinphi
6599       logical :: lprn
6600       integer :: i,interty,j,isccori,isccori1,intertyp
6601 ! Set lprn=.true. for debugging
6602       lprn=.false.
6603 !      lprn=.true.
6604 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6605       esccor=0.0D0
6606       do i=itau_start,itau_end
6607         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6608         esccor_ii=0.0D0
6609         isccori=isccortyp(itype(i-2))
6610         isccori1=isccortyp(itype(i-1))
6611
6612 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6613         phii=phi(i)
6614         do intertyp=1,3 !intertyp
6615          esccor_ii=0.0D0
6616 !c Added 09 May 2012 (Adasko)
6617 !c  Intertyp means interaction type of backbone mainchain correlation:
6618 !   1 = SC...Ca...Ca...Ca
6619 !   2 = Ca...Ca...Ca...SC
6620 !   3 = SC...Ca...Ca...SCi
6621         gloci=0.0D0
6622         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. &
6623             (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. &
6624             (itype(i-1).eq.ntyp1))) &
6625           .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) &
6626            .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) &
6627            .or.(itype(i).eq.ntyp1))) &
6628           .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. &
6629             (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &
6630             (itype(i-3).eq.ntyp1)))) cycle
6631         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6632         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) &
6633        cycle
6634        do j=1,nterm_sccor(isccori,isccori1)
6635           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6636           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6637           cosphi=dcos(j*tauangle(intertyp,i))
6638           sinphi=dsin(j*tauangle(intertyp,i))
6639           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6640           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6641           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6642         enddo
6643         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
6644                                 'esccor',i,intertyp,esccor_ii
6645 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6646         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6647         if (lprn) &
6648         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6649         restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,&
6650         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
6651         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6652         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6653        enddo !intertyp
6654       enddo
6655
6656       return
6657       end subroutine eback_sc_corr
6658 !-----------------------------------------------------------------------------
6659       subroutine multibody(ecorr)
6660 ! This subroutine calculates multi-body contributions to energy following
6661 ! the idea of Skolnick et al. If side chains I and J make a contact and
6662 ! at the same time side chains I+1 and J+1 make a contact, an extra
6663 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6664 !      implicit real*8 (a-h,o-z)
6665 !      include 'DIMENSIONS'
6666 !      include 'COMMON.IOUNITS'
6667 !      include 'COMMON.DERIV'
6668 !      include 'COMMON.INTERACT'
6669 !      include 'COMMON.CONTACTS'
6670       real(kind=8),dimension(3) :: gx,gx1
6671       logical :: lprn
6672       real(kind=8) :: ecorr
6673       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
6674 ! Set lprn=.true. for debugging
6675       lprn=.false.
6676
6677       if (lprn) then
6678         write (iout,'(a)') 'Contact function values:'
6679         do i=nnt,nct-2
6680           write (iout,'(i2,20(1x,i2,f10.5))') &
6681               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6682         enddo
6683       endif
6684       ecorr=0.0D0
6685
6686 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6687 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6688       do i=nnt,nct
6689         do j=1,3
6690           gradcorr(j,i)=0.0D0
6691           gradxorr(j,i)=0.0D0
6692         enddo
6693       enddo
6694       do i=nnt,nct-2
6695
6696         DO ISHIFT = 3,4
6697
6698         i1=i+ishift
6699         num_conti=num_cont(i)
6700         num_conti1=num_cont(i1)
6701         do jj=1,num_conti
6702           j=jcont(jj,i)
6703           do kk=1,num_conti1
6704             j1=jcont(kk,i1)
6705             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6706 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6707 !d   &                   ' ishift=',ishift
6708 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6709 ! The system gains extra energy.
6710               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6711             endif   ! j1==j+-ishift
6712           enddo     ! kk
6713         enddo       ! jj
6714
6715         ENDDO ! ISHIFT
6716
6717       enddo         ! i
6718       return
6719       end subroutine multibody
6720 !-----------------------------------------------------------------------------
6721       real(kind=8) function esccorr(i,j,k,l,jj,kk)
6722 !      implicit real*8 (a-h,o-z)
6723 !      include 'DIMENSIONS'
6724 !      include 'COMMON.IOUNITS'
6725 !      include 'COMMON.DERIV'
6726 !      include 'COMMON.INTERACT'
6727 !      include 'COMMON.CONTACTS'
6728       real(kind=8),dimension(3) :: gx,gx1
6729       logical :: lprn
6730       integer :: i,j,k,l,jj,kk,m,ll
6731       real(kind=8) :: eij,ekl
6732       lprn=.false.
6733       eij=facont(jj,i)
6734       ekl=facont(kk,k)
6735 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6736 ! Calculate the multi-body contribution to energy.
6737 ! Calculate multi-body contributions to the gradient.
6738 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6739 !d   & k,l,(gacont(m,kk,k),m=1,3)
6740       do m=1,3
6741         gx(m) =ekl*gacont(m,jj,i)
6742         gx1(m)=eij*gacont(m,kk,k)
6743         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6744         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6745         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6746         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6747       enddo
6748       do m=i,j-1
6749         do ll=1,3
6750           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6751         enddo
6752       enddo
6753       do m=k,l-1
6754         do ll=1,3
6755           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6756         enddo
6757       enddo
6758       esccorr=-eij*ekl
6759       return
6760       end function esccorr
6761 !-----------------------------------------------------------------------------
6762       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6763 ! This subroutine calculates multi-body contributions to hydrogen-bonding
6764 !      implicit real*8 (a-h,o-z)
6765 !      include 'DIMENSIONS'
6766 !      include 'COMMON.IOUNITS'
6767 #ifdef MPI
6768       include "mpif.h"
6769 !      integer :: maxconts !max_cont=maxconts  =nres/4
6770       integer,parameter :: max_dim=26
6771       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6772       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
6773 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
6774 !el      common /przechowalnia/ zapas
6775       integer :: status(MPI_STATUS_SIZE)
6776       integer,dimension((nres/4)*2) :: req !maxconts*2
6777       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
6778 #endif
6779 !      include 'COMMON.SETUP'
6780 !      include 'COMMON.FFIELD'
6781 !      include 'COMMON.DERIV'
6782 !      include 'COMMON.INTERACT'
6783 !      include 'COMMON.CONTACTS'
6784 !      include 'COMMON.CONTROL'
6785 !      include 'COMMON.LOCAL'
6786       real(kind=8),dimension(3) :: gx,gx1
6787       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
6788       logical :: lprn,ldone
6789 !el local variables
6790       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
6791               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
6792
6793 ! Set lprn=.true. for debugging
6794       lprn=.false.
6795 #ifdef MPI
6796 !      maxconts=nres/4
6797       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
6798       n_corr=0
6799       n_corr1=0
6800       if (nfgtasks.le.1) goto 30
6801       if (lprn) then
6802         write (iout,'(a)') 'Contact function values before RECEIVE:'
6803         do i=nnt,nct-2
6804           write (iout,'(2i3,50(1x,i2,f5.2))') &
6805           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
6806           j=1,num_cont_hb(i))
6807         enddo
6808       endif
6809       call flush(iout)
6810       do i=1,ntask_cont_from
6811         ncont_recv(i)=0
6812       enddo
6813       do i=1,ntask_cont_to
6814         ncont_sent(i)=0
6815       enddo
6816 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6817 !     & ntask_cont_to
6818 ! Make the list of contacts to send to send to other procesors
6819 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6820 !      call flush(iout)
6821       do i=iturn3_start,iturn3_end
6822 !        write (iout,*) "make contact list turn3",i," num_cont",
6823 !     &    num_cont_hb(i)
6824         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6825       enddo
6826       do i=iturn4_start,iturn4_end
6827 !        write (iout,*) "make contact list turn4",i," num_cont",
6828 !     &   num_cont_hb(i)
6829         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6830       enddo
6831       do ii=1,nat_sent
6832         i=iat_sent(ii)
6833 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
6834 !     &    num_cont_hb(i)
6835         do j=1,num_cont_hb(i)
6836         do k=1,4
6837           jjc=jcont_hb(j,i)
6838           iproc=iint_sent_local(k,jjc,ii)
6839 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6840           if (iproc.gt.0) then
6841             ncont_sent(iproc)=ncont_sent(iproc)+1
6842             nn=ncont_sent(iproc)
6843             zapas(1,nn,iproc)=i
6844             zapas(2,nn,iproc)=jjc
6845             zapas(3,nn,iproc)=facont_hb(j,i)
6846             zapas(4,nn,iproc)=ees0p(j,i)
6847             zapas(5,nn,iproc)=ees0m(j,i)
6848             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6849             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6850             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6851             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6852             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6853             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6854             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6855             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6856             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6857             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6858             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6859             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6860             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6861             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6862             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6863             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6864             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6865             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6866             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6867             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6868             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6869           endif
6870         enddo
6871         enddo
6872       enddo
6873       if (lprn) then
6874       write (iout,*) &
6875         "Numbers of contacts to be sent to other processors",&
6876         (ncont_sent(i),i=1,ntask_cont_to)
6877       write (iout,*) "Contacts sent"
6878       do ii=1,ntask_cont_to
6879         nn=ncont_sent(ii)
6880         iproc=itask_cont_to(ii)
6881         write (iout,*) nn," contacts to processor",iproc,&
6882          " of CONT_TO_COMM group"
6883         do i=1,nn
6884           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6885         enddo
6886       enddo
6887       call flush(iout)
6888       endif
6889       CorrelType=477
6890       CorrelID=fg_rank+1
6891       CorrelType1=478
6892       CorrelID1=nfgtasks+fg_rank+1
6893       ireq=0
6894 ! Receive the numbers of needed contacts from other processors
6895       do ii=1,ntask_cont_from
6896         iproc=itask_cont_from(ii)
6897         ireq=ireq+1
6898         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
6899           FG_COMM,req(ireq),IERR)
6900       enddo
6901 !      write (iout,*) "IRECV ended"
6902 !      call flush(iout)
6903 ! Send the number of contacts needed by other processors
6904       do ii=1,ntask_cont_to
6905         iproc=itask_cont_to(ii)
6906         ireq=ireq+1
6907         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
6908           FG_COMM,req(ireq),IERR)
6909       enddo
6910 !      write (iout,*) "ISEND ended"
6911 !      write (iout,*) "number of requests (nn)",ireq
6912       call flush(iout)
6913       if (ireq.gt.0) &
6914         call MPI_Waitall(ireq,req,status_array,ierr)
6915 !      write (iout,*)
6916 !     &  "Numbers of contacts to be received from other processors",
6917 !     &  (ncont_recv(i),i=1,ntask_cont_from)
6918 !      call flush(iout)
6919 ! Receive contacts
6920       ireq=0
6921       do ii=1,ntask_cont_from
6922         iproc=itask_cont_from(ii)
6923         nn=ncont_recv(ii)
6924 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6925 !     &   " of CONT_TO_COMM group"
6926         call flush(iout)
6927         if (nn.gt.0) then
6928           ireq=ireq+1
6929           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
6930           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6931 !          write (iout,*) "ireq,req",ireq,req(ireq)
6932         endif
6933       enddo
6934 ! Send the contacts to processors that need them
6935       do ii=1,ntask_cont_to
6936         iproc=itask_cont_to(ii)
6937         nn=ncont_sent(ii)
6938 !        write (iout,*) nn," contacts to processor",iproc,
6939 !     &   " of CONT_TO_COMM group"
6940         if (nn.gt.0) then
6941           ireq=ireq+1
6942           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
6943             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6944 !          write (iout,*) "ireq,req",ireq,req(ireq)
6945 !          do i=1,nn
6946 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6947 !          enddo
6948         endif
6949       enddo
6950 !      write (iout,*) "number of requests (contacts)",ireq
6951 !      write (iout,*) "req",(req(i),i=1,4)
6952 !      call flush(iout)
6953       if (ireq.gt.0) &
6954        call MPI_Waitall(ireq,req,status_array,ierr)
6955       do iii=1,ntask_cont_from
6956         iproc=itask_cont_from(iii)
6957         nn=ncont_recv(iii)
6958         if (lprn) then
6959         write (iout,*) "Received",nn," contacts from processor",iproc,&
6960          " of CONT_FROM_COMM group"
6961         call flush(iout)
6962         do i=1,nn
6963           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6964         enddo
6965         call flush(iout)
6966         endif
6967         do i=1,nn
6968           ii=zapas_recv(1,i,iii)
6969 ! Flag the received contacts to prevent double-counting
6970           jj=-zapas_recv(2,i,iii)
6971 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6972 !          call flush(iout)
6973           nnn=num_cont_hb(ii)+1
6974           num_cont_hb(ii)=nnn
6975           jcont_hb(nnn,ii)=jj
6976           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6977           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6978           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6979           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6980           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6981           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6982           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6983           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6984           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6985           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6986           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6987           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6988           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6989           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6990           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6991           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6992           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6993           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6994           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6995           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6996           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6997           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6998           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6999           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7000         enddo
7001       enddo
7002       call flush(iout)
7003       if (lprn) then
7004         write (iout,'(a)') 'Contact function values after receive:'
7005         do i=nnt,nct-2
7006           write (iout,'(2i3,50(1x,i3,f5.2))') &
7007           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7008           j=1,num_cont_hb(i))
7009         enddo
7010         call flush(iout)
7011       endif
7012    30 continue
7013 #endif
7014       if (lprn) then
7015         write (iout,'(a)') 'Contact function values:'
7016         do i=nnt,nct-2
7017           write (iout,'(2i3,50(1x,i3,f5.2))') &
7018           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7019           j=1,num_cont_hb(i))
7020         enddo
7021       endif
7022       ecorr=0.0D0
7023
7024 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7025 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7026 ! Remove the loop below after debugging !!!
7027       do i=nnt,nct
7028         do j=1,3
7029           gradcorr(j,i)=0.0D0
7030           gradxorr(j,i)=0.0D0
7031         enddo
7032       enddo
7033 ! Calculate the local-electrostatic correlation terms
7034       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7035         i1=i+1
7036         num_conti=num_cont_hb(i)
7037         num_conti1=num_cont_hb(i+1)
7038         do jj=1,num_conti
7039           j=jcont_hb(jj,i)
7040           jp=iabs(j)
7041           do kk=1,num_conti1
7042             j1=jcont_hb(kk,i1)
7043             jp1=iabs(j1)
7044 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7045 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7046             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7047                 .or. j.lt.0 .and. j1.gt.0) .and. &
7048                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7049 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7050 ! The system gains extra energy.
7051               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7052               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7053                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7054               n_corr=n_corr+1
7055             else if (j1.eq.j) then
7056 ! Contacts I-J and I-(J+1) occur simultaneously.
7057 ! The system loses extra energy.
7058 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7059             endif
7060           enddo ! kk
7061           do kk=1,num_conti
7062             j1=jcont_hb(kk,i)
7063 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7064 !    &         ' jj=',jj,' kk=',kk
7065             if (j1.eq.j+1) then
7066 ! Contacts I-J and (I+1)-J occur simultaneously.
7067 ! The system loses extra energy.
7068 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7069             endif ! j1==j+1
7070           enddo ! kk
7071         enddo ! jj
7072       enddo ! i
7073       return
7074       end subroutine multibody_hb
7075 !-----------------------------------------------------------------------------
7076       subroutine add_hb_contact(ii,jj,itask)
7077 !      implicit real*8 (a-h,o-z)
7078 !      include "DIMENSIONS"
7079 !      include "COMMON.IOUNITS"
7080 !      include "COMMON.CONTACTS"
7081 !      integer,parameter :: maxconts=nres/4
7082       integer,parameter :: max_dim=26
7083       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7084 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7085 !      common /przechowalnia/ zapas
7086       integer :: i,j,ii,jj,iproc,nn,jjc
7087       integer,dimension(4) :: itask
7088 !      write (iout,*) "itask",itask
7089       do i=1,2
7090         iproc=itask(i)
7091         if (iproc.gt.0) then
7092           do j=1,num_cont_hb(ii)
7093             jjc=jcont_hb(j,ii)
7094 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7095             if (jjc.eq.jj) then
7096               ncont_sent(iproc)=ncont_sent(iproc)+1
7097               nn=ncont_sent(iproc)
7098               zapas(1,nn,iproc)=ii
7099               zapas(2,nn,iproc)=jjc
7100               zapas(3,nn,iproc)=facont_hb(j,ii)
7101               zapas(4,nn,iproc)=ees0p(j,ii)
7102               zapas(5,nn,iproc)=ees0m(j,ii)
7103               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7104               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7105               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7106               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7107               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7108               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7109               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7110               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7111               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7112               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7113               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7114               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7115               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7116               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7117               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7118               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7119               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7120               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7121               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7122               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7123               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7124               exit
7125             endif
7126           enddo
7127         endif
7128       enddo
7129       return
7130       end subroutine add_hb_contact
7131 !-----------------------------------------------------------------------------
7132       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7133 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7134 !      implicit real*8 (a-h,o-z)
7135 !      include 'DIMENSIONS'
7136 !      include 'COMMON.IOUNITS'
7137       integer,parameter :: max_dim=70
7138 #ifdef MPI
7139       include "mpif.h"
7140 !      integer :: maxconts !max_cont=maxconts=nres/4
7141       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7142       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7143 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7144 !      common /przechowalnia/ zapas
7145       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7146         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7147         ierr,iii,nnn
7148 #endif
7149 !      include 'COMMON.SETUP'
7150 !      include 'COMMON.FFIELD'
7151 !      include 'COMMON.DERIV'
7152 !      include 'COMMON.LOCAL'
7153 !      include 'COMMON.INTERACT'
7154 !      include 'COMMON.CONTACTS'
7155 !      include 'COMMON.CHAIN'
7156 !      include 'COMMON.CONTROL'
7157       real(kind=8),dimension(3) :: gx,gx1
7158       integer,dimension(nres) :: num_cont_hb_old
7159       logical :: lprn,ldone
7160 !EL      double precision eello4,eello5,eelo6,eello_turn6
7161 !EL      external eello4,eello5,eello6,eello_turn6
7162 !el local variables
7163       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7164               j1,jp1,i1,num_conti1
7165       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7166       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7167
7168 ! Set lprn=.true. for debugging
7169       lprn=.false.
7170       eturn6=0.0d0
7171 #ifdef MPI
7172 !      maxconts=nres/4
7173       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7174       do i=1,nres
7175         num_cont_hb_old(i)=num_cont_hb(i)
7176       enddo
7177       n_corr=0
7178       n_corr1=0
7179       if (nfgtasks.le.1) goto 30
7180       if (lprn) then
7181         write (iout,'(a)') 'Contact function values before RECEIVE:'
7182         do i=nnt,nct-2
7183           write (iout,'(2i3,50(1x,i2,f5.2))') &
7184           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7185           j=1,num_cont_hb(i))
7186         enddo
7187       endif
7188       call flush(iout)
7189       do i=1,ntask_cont_from
7190         ncont_recv(i)=0
7191       enddo
7192       do i=1,ntask_cont_to
7193         ncont_sent(i)=0
7194       enddo
7195 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7196 !     & ntask_cont_to
7197 ! Make the list of contacts to send to send to other procesors
7198       do i=iturn3_start,iturn3_end
7199 !        write (iout,*) "make contact list turn3",i," num_cont",
7200 !     &    num_cont_hb(i)
7201         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7202       enddo
7203       do i=iturn4_start,iturn4_end
7204 !        write (iout,*) "make contact list turn4",i," num_cont",
7205 !     &   num_cont_hb(i)
7206         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7207       enddo
7208       do ii=1,nat_sent
7209         i=iat_sent(ii)
7210 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7211 !     &    num_cont_hb(i)
7212         do j=1,num_cont_hb(i)
7213         do k=1,4
7214           jjc=jcont_hb(j,i)
7215           iproc=iint_sent_local(k,jjc,ii)
7216 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7217           if (iproc.ne.0) then
7218             ncont_sent(iproc)=ncont_sent(iproc)+1
7219             nn=ncont_sent(iproc)
7220             zapas(1,nn,iproc)=i
7221             zapas(2,nn,iproc)=jjc
7222             zapas(3,nn,iproc)=d_cont(j,i)
7223             ind=3
7224             do kk=1,3
7225               ind=ind+1
7226               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7227             enddo
7228             do kk=1,2
7229               do ll=1,2
7230                 ind=ind+1
7231                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7232               enddo
7233             enddo
7234             do jj=1,5
7235               do kk=1,3
7236                 do ll=1,2
7237                   do mm=1,2
7238                     ind=ind+1
7239                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7240                   enddo
7241                 enddo
7242               enddo
7243             enddo
7244           endif
7245         enddo
7246         enddo
7247       enddo
7248       if (lprn) then
7249       write (iout,*) &
7250         "Numbers of contacts to be sent to other processors",&
7251         (ncont_sent(i),i=1,ntask_cont_to)
7252       write (iout,*) "Contacts sent"
7253       do ii=1,ntask_cont_to
7254         nn=ncont_sent(ii)
7255         iproc=itask_cont_to(ii)
7256         write (iout,*) nn," contacts to processor",iproc,&
7257          " of CONT_TO_COMM group"
7258         do i=1,nn
7259           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7260         enddo
7261       enddo
7262       call flush(iout)
7263       endif
7264       CorrelType=477
7265       CorrelID=fg_rank+1
7266       CorrelType1=478
7267       CorrelID1=nfgtasks+fg_rank+1
7268       ireq=0
7269 ! Receive the numbers of needed contacts from other processors
7270       do ii=1,ntask_cont_from
7271         iproc=itask_cont_from(ii)
7272         ireq=ireq+1
7273         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7274           FG_COMM,req(ireq),IERR)
7275       enddo
7276 !      write (iout,*) "IRECV ended"
7277 !      call flush(iout)
7278 ! Send the number of contacts needed by other processors
7279       do ii=1,ntask_cont_to
7280         iproc=itask_cont_to(ii)
7281         ireq=ireq+1
7282         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7283           FG_COMM,req(ireq),IERR)
7284       enddo
7285 !      write (iout,*) "ISEND ended"
7286 !      write (iout,*) "number of requests (nn)",ireq
7287       call flush(iout)
7288       if (ireq.gt.0) &
7289         call MPI_Waitall(ireq,req,status_array,ierr)
7290 !      write (iout,*)
7291 !     &  "Numbers of contacts to be received from other processors",
7292 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7293 !      call flush(iout)
7294 ! Receive contacts
7295       ireq=0
7296       do ii=1,ntask_cont_from
7297         iproc=itask_cont_from(ii)
7298         nn=ncont_recv(ii)
7299 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7300 !     &   " of CONT_TO_COMM group"
7301         call flush(iout)
7302         if (nn.gt.0) then
7303           ireq=ireq+1
7304           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7305           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7306 !          write (iout,*) "ireq,req",ireq,req(ireq)
7307         endif
7308       enddo
7309 ! Send the contacts to processors that need them
7310       do ii=1,ntask_cont_to
7311         iproc=itask_cont_to(ii)
7312         nn=ncont_sent(ii)
7313 !        write (iout,*) nn," contacts to processor",iproc,
7314 !     &   " of CONT_TO_COMM group"
7315         if (nn.gt.0) then
7316           ireq=ireq+1
7317           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7318             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7319 !          write (iout,*) "ireq,req",ireq,req(ireq)
7320 !          do i=1,nn
7321 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7322 !          enddo
7323         endif
7324       enddo
7325 !      write (iout,*) "number of requests (contacts)",ireq
7326 !      write (iout,*) "req",(req(i),i=1,4)
7327 !      call flush(iout)
7328       if (ireq.gt.0) &
7329        call MPI_Waitall(ireq,req,status_array,ierr)
7330       do iii=1,ntask_cont_from
7331         iproc=itask_cont_from(iii)
7332         nn=ncont_recv(iii)
7333         if (lprn) then
7334         write (iout,*) "Received",nn," contacts from processor",iproc,&
7335          " of CONT_FROM_COMM group"
7336         call flush(iout)
7337         do i=1,nn
7338           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7339         enddo
7340         call flush(iout)
7341         endif
7342         do i=1,nn
7343           ii=zapas_recv(1,i,iii)
7344 ! Flag the received contacts to prevent double-counting
7345           jj=-zapas_recv(2,i,iii)
7346 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7347 !          call flush(iout)
7348           nnn=num_cont_hb(ii)+1
7349           num_cont_hb(ii)=nnn
7350           jcont_hb(nnn,ii)=jj
7351           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7352           ind=3
7353           do kk=1,3
7354             ind=ind+1
7355             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7356           enddo
7357           do kk=1,2
7358             do ll=1,2
7359               ind=ind+1
7360               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7361             enddo
7362           enddo
7363           do jj=1,5
7364             do kk=1,3
7365               do ll=1,2
7366                 do mm=1,2
7367                   ind=ind+1
7368                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7369                 enddo
7370               enddo
7371             enddo
7372           enddo
7373         enddo
7374       enddo
7375       call flush(iout)
7376       if (lprn) then
7377         write (iout,'(a)') 'Contact function values after receive:'
7378         do i=nnt,nct-2
7379           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7380           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7381           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7382         enddo
7383         call flush(iout)
7384       endif
7385    30 continue
7386 #endif
7387       if (lprn) then
7388         write (iout,'(a)') 'Contact function values:'
7389         do i=nnt,nct-2
7390           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7391           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7392           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7393         enddo
7394       endif
7395       ecorr=0.0D0
7396       ecorr5=0.0d0
7397       ecorr6=0.0d0
7398
7399 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7400 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7401 ! Remove the loop below after debugging !!!
7402       do i=nnt,nct
7403         do j=1,3
7404           gradcorr(j,i)=0.0D0
7405           gradxorr(j,i)=0.0D0
7406         enddo
7407       enddo
7408 ! Calculate the dipole-dipole interaction energies
7409       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7410       do i=iatel_s,iatel_e+1
7411         num_conti=num_cont_hb(i)
7412         do jj=1,num_conti
7413           j=jcont_hb(jj,i)
7414 #ifdef MOMENT
7415           call dipole(i,j,jj)
7416 #endif
7417         enddo
7418       enddo
7419       endif
7420 ! Calculate the local-electrostatic correlation terms
7421 !                write (iout,*) "gradcorr5 in eello5 before loop"
7422 !                do iii=1,nres
7423 !                  write (iout,'(i5,3f10.5)')
7424 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7425 !                enddo
7426       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7427 !        write (iout,*) "corr loop i",i
7428         i1=i+1
7429         num_conti=num_cont_hb(i)
7430         num_conti1=num_cont_hb(i+1)
7431         do jj=1,num_conti
7432           j=jcont_hb(jj,i)
7433           jp=iabs(j)
7434           do kk=1,num_conti1
7435             j1=jcont_hb(kk,i1)
7436             jp1=iabs(j1)
7437 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7438 !     &         ' jj=',jj,' kk=',kk
7439 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7440             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7441                 .or. j.lt.0 .and. j1.gt.0) .and. &
7442                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7443 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7444 ! The system gains extra energy.
7445               n_corr=n_corr+1
7446               sqd1=dsqrt(d_cont(jj,i))
7447               sqd2=dsqrt(d_cont(kk,i1))
7448               sred_geom = sqd1*sqd2
7449               IF (sred_geom.lt.cutoff_corr) THEN
7450                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7451                   ekont,fprimcont)
7452 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7453 !d     &         ' jj=',jj,' kk=',kk
7454                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7455                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7456                 do l=1,3
7457                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7458                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7459                 enddo
7460                 n_corr1=n_corr1+1
7461 !d               write (iout,*) 'sred_geom=',sred_geom,
7462 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7463 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7464 !d               write (iout,*) "g_contij",g_contij
7465 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7466 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7467                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7468                 if (wcorr4.gt.0.0d0) &
7469                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7470                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7471                        write (iout,'(a6,4i5,0pf7.3)') &
7472                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7473 !                write (iout,*) "gradcorr5 before eello5"
7474 !                do iii=1,nres
7475 !                  write (iout,'(i5,3f10.5)')
7476 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7477 !                enddo
7478                 if (wcorr5.gt.0.0d0) &
7479                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7480 !                write (iout,*) "gradcorr5 after eello5"
7481 !                do iii=1,nres
7482 !                  write (iout,'(i5,3f10.5)')
7483 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7484 !                enddo
7485                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7486                        write (iout,'(a6,4i5,0pf7.3)') &
7487                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7488 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7489 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7490                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7491                      .or. wturn6.eq.0.0d0))then
7492 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7493                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7494                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7495                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7496 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7497 !d     &            'ecorr6=',ecorr6
7498 !d                write (iout,'(4e15.5)') sred_geom,
7499 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7500 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7501 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7502                 else if (wturn6.gt.0.0d0 &
7503                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7504 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7505                   eturn6=eturn6+eello_turn6(i,jj,kk)
7506                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7507                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7508 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7509                 endif
7510               ENDIF
7511 1111          continue
7512             endif
7513           enddo ! kk
7514         enddo ! jj
7515       enddo ! i
7516       do i=1,nres
7517         num_cont_hb(i)=num_cont_hb_old(i)
7518       enddo
7519 !                write (iout,*) "gradcorr5 in eello5"
7520 !                do iii=1,nres
7521 !                  write (iout,'(i5,3f10.5)')
7522 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7523 !                enddo
7524       return
7525       end subroutine multibody_eello
7526 !-----------------------------------------------------------------------------
7527       subroutine add_hb_contact_eello(ii,jj,itask)
7528 !      implicit real*8 (a-h,o-z)
7529 !      include "DIMENSIONS"
7530 !      include "COMMON.IOUNITS"
7531 !      include "COMMON.CONTACTS"
7532 !      integer,parameter :: maxconts=nres/4
7533       integer,parameter :: max_dim=70
7534       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7535 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7536 !      common /przechowalnia/ zapas
7537
7538       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7539       integer,dimension(4) ::itask
7540 !      write (iout,*) "itask",itask
7541       do i=1,2
7542         iproc=itask(i)
7543         if (iproc.gt.0) then
7544           do j=1,num_cont_hb(ii)
7545             jjc=jcont_hb(j,ii)
7546 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7547             if (jjc.eq.jj) then
7548               ncont_sent(iproc)=ncont_sent(iproc)+1
7549               nn=ncont_sent(iproc)
7550               zapas(1,nn,iproc)=ii
7551               zapas(2,nn,iproc)=jjc
7552               zapas(3,nn,iproc)=d_cont(j,ii)
7553               ind=3
7554               do kk=1,3
7555                 ind=ind+1
7556                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7557               enddo
7558               do kk=1,2
7559                 do ll=1,2
7560                   ind=ind+1
7561                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7562                 enddo
7563               enddo
7564               do jj=1,5
7565                 do kk=1,3
7566                   do ll=1,2
7567                     do mm=1,2
7568                       ind=ind+1
7569                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7570                     enddo
7571                   enddo
7572                 enddo
7573               enddo
7574               exit
7575             endif
7576           enddo
7577         endif
7578       enddo
7579       return
7580       end subroutine add_hb_contact_eello
7581 !-----------------------------------------------------------------------------
7582       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7583 !      implicit real*8 (a-h,o-z)
7584 !      include 'DIMENSIONS'
7585 !      include 'COMMON.IOUNITS'
7586 !      include 'COMMON.DERIV'
7587 !      include 'COMMON.INTERACT'
7588 !      include 'COMMON.CONTACTS'
7589       real(kind=8),dimension(3) :: gx,gx1
7590       logical :: lprn
7591 !el local variables
7592       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
7593       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
7594                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
7595                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
7596                    rlocshield
7597
7598       lprn=.false.
7599       eij=facont_hb(jj,i)
7600       ekl=facont_hb(kk,k)
7601       ees0pij=ees0p(jj,i)
7602       ees0pkl=ees0p(kk,k)
7603       ees0mij=ees0m(jj,i)
7604       ees0mkl=ees0m(kk,k)
7605       ekont=eij*ekl
7606       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7607 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7608 ! Following 4 lines for diagnostics.
7609 !d    ees0pkl=0.0D0
7610 !d    ees0pij=1.0D0
7611 !d    ees0mkl=0.0D0
7612 !d    ees0mij=1.0D0
7613 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7614 !     & 'Contacts ',i,j,
7615 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7616 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7617 !     & 'gradcorr_long'
7618 ! Calculate the multi-body contribution to energy.
7619 !      ecorr=ecorr+ekont*ees
7620 ! Calculate multi-body contributions to the gradient.
7621       coeffpees0pij=coeffp*ees0pij
7622       coeffmees0mij=coeffm*ees0mij
7623       coeffpees0pkl=coeffp*ees0pkl
7624       coeffmees0mkl=coeffm*ees0mkl
7625       do ll=1,3
7626 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7627         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
7628         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
7629         coeffmees0mkl*gacontm_hb1(ll,jj,i))
7630         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
7631         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
7632         coeffmees0mkl*gacontm_hb2(ll,jj,i))
7633 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7634         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
7635         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
7636         coeffmees0mij*gacontm_hb1(ll,kk,k))
7637         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
7638         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
7639         coeffmees0mij*gacontm_hb2(ll,kk,k))
7640         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
7641            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
7642            coeffmees0mkl*gacontm_hb3(ll,jj,i))
7643         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7644         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7645         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
7646            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
7647            coeffmees0mij*gacontm_hb3(ll,kk,k))
7648         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7649         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7650 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7651       enddo
7652 !      write (iout,*)
7653 !grad      do m=i+1,j-1
7654 !grad        do ll=1,3
7655 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7656 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7657 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7658 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7659 !grad        enddo
7660 !grad      enddo
7661 !grad      do m=k+1,l-1
7662 !grad        do ll=1,3
7663 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7664 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
7665 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7666 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7667 !grad        enddo
7668 !grad      enddo
7669 !      write (iout,*) "ehbcorr",ekont*ees
7670       ehbcorr=ekont*ees
7671       if (shield_mode.gt.0) then
7672        j=ees0plist(jj,i)
7673        l=ees0plist(kk,k)
7674 !C        print *,i,j,fac_shield(i),fac_shield(j),
7675 !C     &fac_shield(k),fac_shield(l)
7676         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
7677            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7678           do ilist=1,ishield_list(i)
7679            iresshield=shield_list(ilist,i)
7680            do m=1,3
7681            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7682            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7683                    rlocshield  &
7684             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7685             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7686             +rlocshield
7687            enddo
7688           enddo
7689           do ilist=1,ishield_list(j)
7690            iresshield=shield_list(ilist,j)
7691            do m=1,3
7692            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7693            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7694                    rlocshield &
7695             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7696            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7697             +rlocshield
7698            enddo
7699           enddo
7700
7701           do ilist=1,ishield_list(k)
7702            iresshield=shield_list(ilist,k)
7703            do m=1,3
7704            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7705            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7706                    rlocshield &
7707             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7708            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7709             +rlocshield
7710            enddo
7711           enddo
7712           do ilist=1,ishield_list(l)
7713            iresshield=shield_list(ilist,l)
7714            do m=1,3
7715            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7716            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7717                    rlocshield &
7718             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7719            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7720             +rlocshield
7721            enddo
7722           enddo
7723           do m=1,3
7724             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
7725                    grad_shield(m,i)*ehbcorr/fac_shield(i)
7726             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
7727                    grad_shield(m,j)*ehbcorr/fac_shield(j)
7728             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
7729                    grad_shield(m,i)*ehbcorr/fac_shield(i)
7730             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
7731                    grad_shield(m,j)*ehbcorr/fac_shield(j)
7732
7733             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
7734                    grad_shield(m,k)*ehbcorr/fac_shield(k)
7735             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
7736                    grad_shield(m,l)*ehbcorr/fac_shield(l)
7737             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
7738                    grad_shield(m,k)*ehbcorr/fac_shield(k)
7739             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
7740                    grad_shield(m,l)*ehbcorr/fac_shield(l)
7741
7742            enddo
7743       endif
7744       endif
7745       return
7746       end function ehbcorr
7747 #ifdef MOMENT
7748 !-----------------------------------------------------------------------------
7749       subroutine dipole(i,j,jj)
7750 !      implicit real*8 (a-h,o-z)
7751 !      include 'DIMENSIONS'
7752 !      include 'COMMON.IOUNITS'
7753 !      include 'COMMON.CHAIN'
7754 !      include 'COMMON.FFIELD'
7755 !      include 'COMMON.DERIV'
7756 !      include 'COMMON.INTERACT'
7757 !      include 'COMMON.CONTACTS'
7758 !      include 'COMMON.TORSION'
7759 !      include 'COMMON.VAR'
7760 !      include 'COMMON.GEO'
7761       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
7762       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
7763       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
7764
7765       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
7766       allocate(dipderx(3,5,4,maxconts,nres))
7767 !
7768
7769       iti1 = itortyp(itype(i+1))
7770       if (j.lt.nres-1) then
7771         itj1 = itortyp(itype(j+1))
7772       else
7773         itj1=ntortyp+1
7774       endif
7775       do iii=1,2
7776         dipi(iii,1)=Ub2(iii,i)
7777         dipderi(iii)=Ub2der(iii,i)
7778         dipi(iii,2)=b1(iii,iti1)
7779         dipj(iii,1)=Ub2(iii,j)
7780         dipderj(iii)=Ub2der(iii,j)
7781         dipj(iii,2)=b1(iii,itj1)
7782       enddo
7783       kkk=0
7784       do iii=1,2
7785         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7786         do jjj=1,2
7787           kkk=kkk+1
7788           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7789         enddo
7790       enddo
7791       do kkk=1,5
7792         do lll=1,3
7793           mmm=0
7794           do iii=1,2
7795             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
7796               auxvec(1))
7797             do jjj=1,2
7798               mmm=mmm+1
7799               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7800             enddo
7801           enddo
7802         enddo
7803       enddo
7804       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7805       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7806       do iii=1,2
7807         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7808       enddo
7809       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7810       do iii=1,2
7811         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7812       enddo
7813       return
7814       end subroutine dipole
7815 #endif
7816 !-----------------------------------------------------------------------------
7817       subroutine calc_eello(i,j,k,l,jj,kk)
7818 !
7819 ! This subroutine computes matrices and vectors needed to calculate
7820 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
7821 !
7822       use comm_kut
7823 !      implicit real*8 (a-h,o-z)
7824 !      include 'DIMENSIONS'
7825 !      include 'COMMON.IOUNITS'
7826 !      include 'COMMON.CHAIN'
7827 !      include 'COMMON.DERIV'
7828 !      include 'COMMON.INTERACT'
7829 !      include 'COMMON.CONTACTS'
7830 !      include 'COMMON.TORSION'
7831 !      include 'COMMON.VAR'
7832 !      include 'COMMON.GEO'
7833 !      include 'COMMON.FFIELD'
7834       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
7835       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
7836       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
7837               itj1
7838 !el      logical :: lprn
7839 !el      common /kutas/ lprn
7840 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7841 !d     & ' jj=',jj,' kk=',kk
7842 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7843 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7844 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7845       do iii=1,2
7846         do jjj=1,2
7847           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7848           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7849         enddo
7850       enddo
7851       call transpose2(aa1(1,1),aa1t(1,1))
7852       call transpose2(aa2(1,1),aa2t(1,1))
7853       do kkk=1,5
7854         do lll=1,3
7855           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
7856             aa1tder(1,1,lll,kkk))
7857           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
7858             aa2tder(1,1,lll,kkk))
7859         enddo
7860       enddo
7861       if (l.eq.j+1) then
7862 ! parallel orientation of the two CA-CA-CA frames.
7863         if (i.gt.1) then
7864           iti=itortyp(itype(i))
7865         else
7866           iti=ntortyp+1
7867         endif
7868         itk1=itortyp(itype(k+1))
7869         itj=itortyp(itype(j))
7870         if (l.lt.nres-1) then
7871           itl1=itortyp(itype(l+1))
7872         else
7873           itl1=ntortyp+1
7874         endif
7875 ! A1 kernel(j+1) A2T
7876 !d        do iii=1,2
7877 !d          write (iout,'(3f10.5,5x,3f10.5)')
7878 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7879 !d        enddo
7880         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7881          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
7882          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7883 ! Following matrices are needed only for 6-th order cumulants
7884         IF (wcorr6.gt.0.0d0) THEN
7885         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7886          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
7887          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7888         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7889          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
7890          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
7891          ADtEAderx(1,1,1,1,1,1))
7892         lprn=.false.
7893         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
7894          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
7895          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
7896          ADtEA1derx(1,1,1,1,1,1))
7897         ENDIF
7898 ! End 6-th order cumulants
7899 !d        lprn=.false.
7900 !d        if (lprn) then
7901 !d        write (2,*) 'In calc_eello6'
7902 !d        do iii=1,2
7903 !d          write (2,*) 'iii=',iii
7904 !d          do kkk=1,5
7905 !d            write (2,*) 'kkk=',kkk
7906 !d            do jjj=1,2
7907 !d              write (2,'(3(2f10.5),5x)')
7908 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7909 !d            enddo
7910 !d          enddo
7911 !d        enddo
7912 !d        endif
7913         call transpose2(EUgder(1,1,k),auxmat(1,1))
7914         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7915         call transpose2(EUg(1,1,k),auxmat(1,1))
7916         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7917         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7918         do iii=1,2
7919           do kkk=1,5
7920             do lll=1,3
7921               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
7922                 EAEAderx(1,1,lll,kkk,iii,1))
7923             enddo
7924           enddo
7925         enddo
7926 ! A1T kernel(i+1) A2
7927         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7928          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
7929          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7930 ! Following matrices are needed only for 6-th order cumulants
7931         IF (wcorr6.gt.0.0d0) THEN
7932         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7933          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
7934          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7935         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7936          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
7937          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
7938          ADtEAderx(1,1,1,1,1,2))
7939         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
7940          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
7941          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
7942          ADtEA1derx(1,1,1,1,1,2))
7943         ENDIF
7944 ! End 6-th order cumulants
7945         call transpose2(EUgder(1,1,l),auxmat(1,1))
7946         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7947         call transpose2(EUg(1,1,l),auxmat(1,1))
7948         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7949         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7950         do iii=1,2
7951           do kkk=1,5
7952             do lll=1,3
7953               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
7954                 EAEAderx(1,1,lll,kkk,iii,2))
7955             enddo
7956           enddo
7957         enddo
7958 ! AEAb1 and AEAb2
7959 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7960 ! They are needed only when the fifth- or the sixth-order cumulants are
7961 ! indluded.
7962         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7963         call transpose2(AEA(1,1,1),auxmat(1,1))
7964         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7965         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7966         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7967         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7968         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7969         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7970         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7971         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7972         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7973         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7974         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7975         call transpose2(AEA(1,1,2),auxmat(1,1))
7976         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7977         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7978         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7979         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7980         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7981         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7982         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7983         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7984         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7985         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7986         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7987 ! Calculate the Cartesian derivatives of the vectors.
7988         do iii=1,2
7989           do kkk=1,5
7990             do lll=1,3
7991               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7992               call matvec2(auxmat(1,1),b1(1,iti),&
7993                 AEAb1derx(1,lll,kkk,iii,1,1))
7994               call matvec2(auxmat(1,1),Ub2(1,i),&
7995                 AEAb2derx(1,lll,kkk,iii,1,1))
7996               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
7997                 AEAb1derx(1,lll,kkk,iii,2,1))
7998               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
7999                 AEAb2derx(1,lll,kkk,iii,2,1))
8000               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8001               call matvec2(auxmat(1,1),b1(1,itj),&
8002                 AEAb1derx(1,lll,kkk,iii,1,2))
8003               call matvec2(auxmat(1,1),Ub2(1,j),&
8004                 AEAb2derx(1,lll,kkk,iii,1,2))
8005               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8006                 AEAb1derx(1,lll,kkk,iii,2,2))
8007               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8008                 AEAb2derx(1,lll,kkk,iii,2,2))
8009             enddo
8010           enddo
8011         enddo
8012         ENDIF
8013 ! End vectors
8014       else
8015 ! Antiparallel orientation of the two CA-CA-CA frames.
8016         if (i.gt.1) then
8017           iti=itortyp(itype(i))
8018         else
8019           iti=ntortyp+1
8020         endif
8021         itk1=itortyp(itype(k+1))
8022         itl=itortyp(itype(l))
8023         itj=itortyp(itype(j))
8024         if (j.lt.nres-1) then
8025           itj1=itortyp(itype(j+1))
8026         else
8027           itj1=ntortyp+1
8028         endif
8029 ! A2 kernel(j-1)T A1T
8030         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8031          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8032          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8033 ! Following matrices are needed only for 6-th order cumulants
8034         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8035            j.eq.i+4 .and. l.eq.i+3)) THEN
8036         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8037          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8038          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8039         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8040          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8041          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8042          ADtEAderx(1,1,1,1,1,1))
8043         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8044          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8045          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8046          ADtEA1derx(1,1,1,1,1,1))
8047         ENDIF
8048 ! End 6-th order cumulants
8049         call transpose2(EUgder(1,1,k),auxmat(1,1))
8050         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8051         call transpose2(EUg(1,1,k),auxmat(1,1))
8052         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8053         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8054         do iii=1,2
8055           do kkk=1,5
8056             do lll=1,3
8057               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8058                 EAEAderx(1,1,lll,kkk,iii,1))
8059             enddo
8060           enddo
8061         enddo
8062 ! A2T kernel(i+1)T A1
8063         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8064          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8065          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8066 ! Following matrices are needed only for 6-th order cumulants
8067         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8068            j.eq.i+4 .and. l.eq.i+3)) THEN
8069         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8070          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8071          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8072         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8073          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8074          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8075          ADtEAderx(1,1,1,1,1,2))
8076         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8077          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8078          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8079          ADtEA1derx(1,1,1,1,1,2))
8080         ENDIF
8081 ! End 6-th order cumulants
8082         call transpose2(EUgder(1,1,j),auxmat(1,1))
8083         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8084         call transpose2(EUg(1,1,j),auxmat(1,1))
8085         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8086         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8087         do iii=1,2
8088           do kkk=1,5
8089             do lll=1,3
8090               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8091                 EAEAderx(1,1,lll,kkk,iii,2))
8092             enddo
8093           enddo
8094         enddo
8095 ! AEAb1 and AEAb2
8096 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8097 ! They are needed only when the fifth- or the sixth-order cumulants are
8098 ! indluded.
8099         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8100           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8101         call transpose2(AEA(1,1,1),auxmat(1,1))
8102         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8103         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8104         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8105         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8106         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8107         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8108         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8109         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8110         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8111         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8112         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8113         call transpose2(AEA(1,1,2),auxmat(1,1))
8114         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8115         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8116         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8117         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8118         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8119         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8120         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8121         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8122         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8123         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8124         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8125 ! Calculate the Cartesian derivatives of the vectors.
8126         do iii=1,2
8127           do kkk=1,5
8128             do lll=1,3
8129               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8130               call matvec2(auxmat(1,1),b1(1,iti),&
8131                 AEAb1derx(1,lll,kkk,iii,1,1))
8132               call matvec2(auxmat(1,1),Ub2(1,i),&
8133                 AEAb2derx(1,lll,kkk,iii,1,1))
8134               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8135                 AEAb1derx(1,lll,kkk,iii,2,1))
8136               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8137                 AEAb2derx(1,lll,kkk,iii,2,1))
8138               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8139               call matvec2(auxmat(1,1),b1(1,itl),&
8140                 AEAb1derx(1,lll,kkk,iii,1,2))
8141               call matvec2(auxmat(1,1),Ub2(1,l),&
8142                 AEAb2derx(1,lll,kkk,iii,1,2))
8143               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8144                 AEAb1derx(1,lll,kkk,iii,2,2))
8145               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8146                 AEAb2derx(1,lll,kkk,iii,2,2))
8147             enddo
8148           enddo
8149         enddo
8150         ENDIF
8151 ! End vectors
8152       endif
8153       return
8154       end subroutine calc_eello
8155 !-----------------------------------------------------------------------------
8156       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8157       use comm_kut
8158       implicit none
8159       integer :: nderg
8160       logical :: transp
8161       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8162       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8163       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8164       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8165       integer :: iii,kkk,lll
8166       integer :: jjj,mmm
8167 !el      logical :: lprn
8168 !el      common /kutas/ lprn
8169       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8170       do iii=1,nderg
8171         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8172           AKAderg(1,1,iii))
8173       enddo
8174 !d      if (lprn) write (2,*) 'In kernel'
8175       do kkk=1,5
8176 !d        if (lprn) write (2,*) 'kkk=',kkk
8177         do lll=1,3
8178           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8179             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8180 !d          if (lprn) then
8181 !d            write (2,*) 'lll=',lll
8182 !d            write (2,*) 'iii=1'
8183 !d            do jjj=1,2
8184 !d              write (2,'(3(2f10.5),5x)')
8185 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8186 !d            enddo
8187 !d          endif
8188           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8189             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8190 !d          if (lprn) then
8191 !d            write (2,*) 'lll=',lll
8192 !d            write (2,*) 'iii=2'
8193 !d            do jjj=1,2
8194 !d              write (2,'(3(2f10.5),5x)')
8195 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8196 !d            enddo
8197 !d          endif
8198         enddo
8199       enddo
8200       return
8201       end subroutine kernel
8202 !-----------------------------------------------------------------------------
8203       real(kind=8) function eello4(i,j,k,l,jj,kk)
8204 !      implicit real*8 (a-h,o-z)
8205 !      include 'DIMENSIONS'
8206 !      include 'COMMON.IOUNITS'
8207 !      include 'COMMON.CHAIN'
8208 !      include 'COMMON.DERIV'
8209 !      include 'COMMON.INTERACT'
8210 !      include 'COMMON.CONTACTS'
8211 !      include 'COMMON.TORSION'
8212 !      include 'COMMON.VAR'
8213 !      include 'COMMON.GEO'
8214       real(kind=8),dimension(2,2) :: pizda
8215       real(kind=8),dimension(3) :: ggg1,ggg2
8216       real(kind=8) ::  eel4,glongij,glongkl
8217       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8218 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8219 !d        eello4=0.0d0
8220 !d        return
8221 !d      endif
8222 !d      print *,'eello4:',i,j,k,l,jj,kk
8223 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8224 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8225 !old      eij=facont_hb(jj,i)
8226 !old      ekl=facont_hb(kk,k)
8227 !old      ekont=eij*ekl
8228       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8229 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8230       gcorr_loc(k-1)=gcorr_loc(k-1) &
8231          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8232       if (l.eq.j+1) then
8233         gcorr_loc(l-1)=gcorr_loc(l-1) &
8234            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8235       else
8236         gcorr_loc(j-1)=gcorr_loc(j-1) &
8237            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8238       endif
8239       do iii=1,2
8240         do kkk=1,5
8241           do lll=1,3
8242             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8243                               -EAEAderx(2,2,lll,kkk,iii,1)
8244 !d            derx(lll,kkk,iii)=0.0d0
8245           enddo
8246         enddo
8247       enddo
8248 !d      gcorr_loc(l-1)=0.0d0
8249 !d      gcorr_loc(j-1)=0.0d0
8250 !d      gcorr_loc(k-1)=0.0d0
8251 !d      eel4=1.0d0
8252 !d      write (iout,*)'Contacts have occurred for peptide groups',
8253 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8254 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8255       if (j.lt.nres-1) then
8256         j1=j+1
8257         j2=j-1
8258       else
8259         j1=j-1
8260         j2=j-2
8261       endif
8262       if (l.lt.nres-1) then
8263         l1=l+1
8264         l2=l-1
8265       else
8266         l1=l-1
8267         l2=l-2
8268       endif
8269       do ll=1,3
8270 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8271 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8272         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8273         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8274 !grad        ghalf=0.5d0*ggg1(ll)
8275         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8276         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8277         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8278         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8279         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8280         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8281 !grad        ghalf=0.5d0*ggg2(ll)
8282         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8283         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8284         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8285         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8286         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8287         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8288       enddo
8289 !grad      do m=i+1,j-1
8290 !grad        do ll=1,3
8291 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8292 !grad        enddo
8293 !grad      enddo
8294 !grad      do m=k+1,l-1
8295 !grad        do ll=1,3
8296 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8297 !grad        enddo
8298 !grad      enddo
8299 !grad      do m=i+2,j2
8300 !grad        do ll=1,3
8301 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8302 !grad        enddo
8303 !grad      enddo
8304 !grad      do m=k+2,l2
8305 !grad        do ll=1,3
8306 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8307 !grad        enddo
8308 !grad      enddo
8309 !d      do iii=1,nres-3
8310 !d        write (2,*) iii,gcorr_loc(iii)
8311 !d      enddo
8312       eello4=ekont*eel4
8313 !d      write (2,*) 'ekont',ekont
8314 !d      write (iout,*) 'eello4',ekont*eel4
8315       return
8316       end function eello4
8317 !-----------------------------------------------------------------------------
8318       real(kind=8) function eello5(i,j,k,l,jj,kk)
8319 !      implicit real*8 (a-h,o-z)
8320 !      include 'DIMENSIONS'
8321 !      include 'COMMON.IOUNITS'
8322 !      include 'COMMON.CHAIN'
8323 !      include 'COMMON.DERIV'
8324 !      include 'COMMON.INTERACT'
8325 !      include 'COMMON.CONTACTS'
8326 !      include 'COMMON.TORSION'
8327 !      include 'COMMON.VAR'
8328 !      include 'COMMON.GEO'
8329       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8330       real(kind=8),dimension(2) :: vv
8331       real(kind=8),dimension(3) :: ggg1,ggg2
8332       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8333       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8334       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8335 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8336 !                                                                              C
8337 !                            Parallel chains                                   C
8338 !                                                                              C
8339 !          o             o                   o             o                   C
8340 !         /l\           / \             \   / \           / \   /              C
8341 !        /   \         /   \             \ /   \         /   \ /               C
8342 !       j| o |l1       | o |              o| o |         | o |o                C
8343 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8344 !      \i/   \         /   \ /             /   \         /   \                 C
8345 !       o    k1             o                                                  C
8346 !         (I)          (II)                (III)          (IV)                 C
8347 !                                                                              C
8348 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8349 !                                                                              C
8350 !                            Antiparallel chains                               C
8351 !                                                                              C
8352 !          o             o                   o             o                   C
8353 !         /j\           / \             \   / \           / \   /              C
8354 !        /   \         /   \             \ /   \         /   \ /               C
8355 !      j1| o |l        | o |              o| o |         | o |o                C
8356 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8357 !      \i/   \         /   \ /             /   \         /   \                 C
8358 !       o     k1            o                                                  C
8359 !         (I)          (II)                (III)          (IV)                 C
8360 !                                                                              C
8361 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8362 !                                                                              C
8363 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8364 !                                                                              C
8365 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8366 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8367 !d        eello5=0.0d0
8368 !d        return
8369 !d      endif
8370 !d      write (iout,*)
8371 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8372 !d     &   ' and',k,l
8373       itk=itortyp(itype(k))
8374       itl=itortyp(itype(l))
8375       itj=itortyp(itype(j))
8376       eello5_1=0.0d0
8377       eello5_2=0.0d0
8378       eello5_3=0.0d0
8379       eello5_4=0.0d0
8380 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8381 !d     &   eel5_3_num,eel5_4_num)
8382       do iii=1,2
8383         do kkk=1,5
8384           do lll=1,3
8385             derx(lll,kkk,iii)=0.0d0
8386           enddo
8387         enddo
8388       enddo
8389 !d      eij=facont_hb(jj,i)
8390 !d      ekl=facont_hb(kk,k)
8391 !d      ekont=eij*ekl
8392 !d      write (iout,*)'Contacts have occurred for peptide groups',
8393 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8394 !d      goto 1111
8395 ! Contribution from the graph I.
8396 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8397 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8398       call transpose2(EUg(1,1,k),auxmat(1,1))
8399       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8400       vv(1)=pizda(1,1)-pizda(2,2)
8401       vv(2)=pizda(1,2)+pizda(2,1)
8402       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8403        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8404 ! Explicit gradient in virtual-dihedral angles.
8405       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8406        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8407        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8408       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8409       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8410       vv(1)=pizda(1,1)-pizda(2,2)
8411       vv(2)=pizda(1,2)+pizda(2,1)
8412       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8413        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8414        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8415       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8416       vv(1)=pizda(1,1)-pizda(2,2)
8417       vv(2)=pizda(1,2)+pizda(2,1)
8418       if (l.eq.j+1) then
8419         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8420          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8421          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8422       else
8423         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8424          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8425          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8426       endif
8427 ! Cartesian gradient
8428       do iii=1,2
8429         do kkk=1,5
8430           do lll=1,3
8431             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8432               pizda(1,1))
8433             vv(1)=pizda(1,1)-pizda(2,2)
8434             vv(2)=pizda(1,2)+pizda(2,1)
8435             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8436              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8437              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8438           enddo
8439         enddo
8440       enddo
8441 !      goto 1112
8442 !1111  continue
8443 ! Contribution from graph II
8444       call transpose2(EE(1,1,itk),auxmat(1,1))
8445       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8446       vv(1)=pizda(1,1)+pizda(2,2)
8447       vv(2)=pizda(2,1)-pizda(1,2)
8448       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8449        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8450 ! Explicit gradient in virtual-dihedral angles.
8451       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8452        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8453       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8454       vv(1)=pizda(1,1)+pizda(2,2)
8455       vv(2)=pizda(2,1)-pizda(1,2)
8456       if (l.eq.j+1) then
8457         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8458          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8459          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8460       else
8461         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8462          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8463          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8464       endif
8465 ! Cartesian gradient
8466       do iii=1,2
8467         do kkk=1,5
8468           do lll=1,3
8469             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8470               pizda(1,1))
8471             vv(1)=pizda(1,1)+pizda(2,2)
8472             vv(2)=pizda(2,1)-pizda(1,2)
8473             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8474              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8475              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8476           enddo
8477         enddo
8478       enddo
8479 !d      goto 1112
8480 !d1111  continue
8481       if (l.eq.j+1) then
8482 !d        goto 1110
8483 ! Parallel orientation
8484 ! Contribution from graph III
8485         call transpose2(EUg(1,1,l),auxmat(1,1))
8486         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8487         vv(1)=pizda(1,1)-pizda(2,2)
8488         vv(2)=pizda(1,2)+pizda(2,1)
8489         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8490          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8491 ! Explicit gradient in virtual-dihedral angles.
8492         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8493          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8494          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8495         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8496         vv(1)=pizda(1,1)-pizda(2,2)
8497         vv(2)=pizda(1,2)+pizda(2,1)
8498         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8499          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8500          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8501         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8502         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8503         vv(1)=pizda(1,1)-pizda(2,2)
8504         vv(2)=pizda(1,2)+pizda(2,1)
8505         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8506          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8507          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8508 ! Cartesian gradient
8509         do iii=1,2
8510           do kkk=1,5
8511             do lll=1,3
8512               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8513                 pizda(1,1))
8514               vv(1)=pizda(1,1)-pizda(2,2)
8515               vv(2)=pizda(1,2)+pizda(2,1)
8516               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8517                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8518                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8519             enddo
8520           enddo
8521         enddo
8522 !d        goto 1112
8523 ! Contribution from graph IV
8524 !d1110    continue
8525         call transpose2(EE(1,1,itl),auxmat(1,1))
8526         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8527         vv(1)=pizda(1,1)+pizda(2,2)
8528         vv(2)=pizda(2,1)-pizda(1,2)
8529         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8530          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8531 ! Explicit gradient in virtual-dihedral angles.
8532         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8533          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8534         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8535         vv(1)=pizda(1,1)+pizda(2,2)
8536         vv(2)=pizda(2,1)-pizda(1,2)
8537         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8538          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8539          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8540 ! Cartesian gradient
8541         do iii=1,2
8542           do kkk=1,5
8543             do lll=1,3
8544               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8545                 pizda(1,1))
8546               vv(1)=pizda(1,1)+pizda(2,2)
8547               vv(2)=pizda(2,1)-pizda(1,2)
8548               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8549                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8550                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8551             enddo
8552           enddo
8553         enddo
8554       else
8555 ! Antiparallel orientation
8556 ! Contribution from graph III
8557 !        goto 1110
8558         call transpose2(EUg(1,1,j),auxmat(1,1))
8559         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8560         vv(1)=pizda(1,1)-pizda(2,2)
8561         vv(2)=pizda(1,2)+pizda(2,1)
8562         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8563          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8564 ! Explicit gradient in virtual-dihedral angles.
8565         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8566          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8567          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8568         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8569         vv(1)=pizda(1,1)-pizda(2,2)
8570         vv(2)=pizda(1,2)+pizda(2,1)
8571         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8572          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
8573          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8574         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8575         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8576         vv(1)=pizda(1,1)-pizda(2,2)
8577         vv(2)=pizda(1,2)+pizda(2,1)
8578         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8579          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
8580          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8581 ! Cartesian gradient
8582         do iii=1,2
8583           do kkk=1,5
8584             do lll=1,3
8585               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8586                 pizda(1,1))
8587               vv(1)=pizda(1,1)-pizda(2,2)
8588               vv(2)=pizda(1,2)+pizda(2,1)
8589               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8590                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
8591                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8592             enddo
8593           enddo
8594         enddo
8595 !d        goto 1112
8596 ! Contribution from graph IV
8597 1110    continue
8598         call transpose2(EE(1,1,itj),auxmat(1,1))
8599         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8600         vv(1)=pizda(1,1)+pizda(2,2)
8601         vv(2)=pizda(2,1)-pizda(1,2)
8602         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
8603          -0.5d0*scalar2(vv(1),Ctobr(1,j))
8604 ! Explicit gradient in virtual-dihedral angles.
8605         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8606          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8607         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8608         vv(1)=pizda(1,1)+pizda(2,2)
8609         vv(2)=pizda(2,1)-pizda(1,2)
8610         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8611          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
8612          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8613 ! Cartesian gradient
8614         do iii=1,2
8615           do kkk=1,5
8616             do lll=1,3
8617               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8618                 pizda(1,1))
8619               vv(1)=pizda(1,1)+pizda(2,2)
8620               vv(2)=pizda(2,1)-pizda(1,2)
8621               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8622                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
8623                -0.5d0*scalar2(vv(1),Ctobr(1,j))
8624             enddo
8625           enddo
8626         enddo
8627       endif
8628 1112  continue
8629       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8630 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8631 !d        write (2,*) 'ijkl',i,j,k,l
8632 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8633 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8634 !d      endif
8635 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8636 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8637 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8638 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8639       if (j.lt.nres-1) then
8640         j1=j+1
8641         j2=j-1
8642       else
8643         j1=j-1
8644         j2=j-2
8645       endif
8646       if (l.lt.nres-1) then
8647         l1=l+1
8648         l2=l-1
8649       else
8650         l1=l-1
8651         l2=l-2
8652       endif
8653 !d      eij=1.0d0
8654 !d      ekl=1.0d0
8655 !d      ekont=1.0d0
8656 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8657 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
8658 !        summed up outside the subrouine as for the other subroutines
8659 !        handling long-range interactions. The old code is commented out
8660 !        with "cgrad" to keep track of changes.
8661       do ll=1,3
8662 !grad        ggg1(ll)=eel5*g_contij(ll,1)
8663 !grad        ggg2(ll)=eel5*g_contij(ll,2)
8664         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8665         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8666 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8667 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8668 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8669 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8670 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8671 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8672 !     &   gradcorr5ij,
8673 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8674 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8675 !grad        ghalf=0.5d0*ggg1(ll)
8676 !d        ghalf=0.0d0
8677         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8678         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8679         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8680         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8681         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8682         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8683 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8684 !grad        ghalf=0.5d0*ggg2(ll)
8685         ghalf=0.0d0
8686         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8687         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8688         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8689         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8690         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8691         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8692       enddo
8693 !d      goto 1112
8694 !grad      do m=i+1,j-1
8695 !grad        do ll=1,3
8696 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8697 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8698 !grad        enddo
8699 !grad      enddo
8700 !grad      do m=k+1,l-1
8701 !grad        do ll=1,3
8702 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8703 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8704 !grad        enddo
8705 !grad      enddo
8706 !1112  continue
8707 !grad      do m=i+2,j2
8708 !grad        do ll=1,3
8709 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8710 !grad        enddo
8711 !grad      enddo
8712 !grad      do m=k+2,l2
8713 !grad        do ll=1,3
8714 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8715 !grad        enddo
8716 !grad      enddo
8717 !d      do iii=1,nres-3
8718 !d        write (2,*) iii,g_corr5_loc(iii)
8719 !d      enddo
8720       eello5=ekont*eel5
8721 !d      write (2,*) 'ekont',ekont
8722 !d      write (iout,*) 'eello5',ekont*eel5
8723       return
8724       end function eello5
8725 !-----------------------------------------------------------------------------
8726       real(kind=8) function eello6(i,j,k,l,jj,kk)
8727 !      implicit real*8 (a-h,o-z)
8728 !      include 'DIMENSIONS'
8729 !      include 'COMMON.IOUNITS'
8730 !      include 'COMMON.CHAIN'
8731 !      include 'COMMON.DERIV'
8732 !      include 'COMMON.INTERACT'
8733 !      include 'COMMON.CONTACTS'
8734 !      include 'COMMON.TORSION'
8735 !      include 'COMMON.VAR'
8736 !      include 'COMMON.GEO'
8737 !      include 'COMMON.FFIELD'
8738       real(kind=8),dimension(3) :: ggg1,ggg2
8739       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
8740                    eello6_6,eel6
8741       real(kind=8) :: gradcorr6ij,gradcorr6kl
8742       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8743 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8744 !d        eello6=0.0d0
8745 !d        return
8746 !d      endif
8747 !d      write (iout,*)
8748 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8749 !d     &   ' and',k,l
8750       eello6_1=0.0d0
8751       eello6_2=0.0d0
8752       eello6_3=0.0d0
8753       eello6_4=0.0d0
8754       eello6_5=0.0d0
8755       eello6_6=0.0d0
8756 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8757 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8758       do iii=1,2
8759         do kkk=1,5
8760           do lll=1,3
8761             derx(lll,kkk,iii)=0.0d0
8762           enddo
8763         enddo
8764       enddo
8765 !d      eij=facont_hb(jj,i)
8766 !d      ekl=facont_hb(kk,k)
8767 !d      ekont=eij*ekl
8768 !d      eij=1.0d0
8769 !d      ekl=1.0d0
8770 !d      ekont=1.0d0
8771       if (l.eq.j+1) then
8772         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8773         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8774         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8775         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8776         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8777         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8778       else
8779         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8780         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8781         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8782         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8783         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8784           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8785         else
8786           eello6_5=0.0d0
8787         endif
8788         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8789       endif
8790 ! If turn contributions are considered, they will be handled separately.
8791       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8792 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8793 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8794 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8795 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8796 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8797 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8798 !d      goto 1112
8799       if (j.lt.nres-1) then
8800         j1=j+1
8801         j2=j-1
8802       else
8803         j1=j-1
8804         j2=j-2
8805       endif
8806       if (l.lt.nres-1) then
8807         l1=l+1
8808         l2=l-1
8809       else
8810         l1=l-1
8811         l2=l-2
8812       endif
8813       do ll=1,3
8814 !grad        ggg1(ll)=eel6*g_contij(ll,1)
8815 !grad        ggg2(ll)=eel6*g_contij(ll,2)
8816 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8817 !grad        ghalf=0.5d0*ggg1(ll)
8818 !d        ghalf=0.0d0
8819         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8820         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8821         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8822         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8823         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8824         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8825         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8826         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8827 !grad        ghalf=0.5d0*ggg2(ll)
8828 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8829 !d        ghalf=0.0d0
8830         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8831         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8832         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8833         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8834         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8835         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8836       enddo
8837 !d      goto 1112
8838 !grad      do m=i+1,j-1
8839 !grad        do ll=1,3
8840 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8841 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8842 !grad        enddo
8843 !grad      enddo
8844 !grad      do m=k+1,l-1
8845 !grad        do ll=1,3
8846 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8847 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8848 !grad        enddo
8849 !grad      enddo
8850 !grad1112  continue
8851 !grad      do m=i+2,j2
8852 !grad        do ll=1,3
8853 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8854 !grad        enddo
8855 !grad      enddo
8856 !grad      do m=k+2,l2
8857 !grad        do ll=1,3
8858 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8859 !grad        enddo
8860 !grad      enddo
8861 !d      do iii=1,nres-3
8862 !d        write (2,*) iii,g_corr6_loc(iii)
8863 !d      enddo
8864       eello6=ekont*eel6
8865 !d      write (2,*) 'ekont',ekont
8866 !d      write (iout,*) 'eello6',ekont*eel6
8867       return
8868       end function eello6
8869 !-----------------------------------------------------------------------------
8870       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
8871       use comm_kut
8872 !      implicit real*8 (a-h,o-z)
8873 !      include 'DIMENSIONS'
8874 !      include 'COMMON.IOUNITS'
8875 !      include 'COMMON.CHAIN'
8876 !      include 'COMMON.DERIV'
8877 !      include 'COMMON.INTERACT'
8878 !      include 'COMMON.CONTACTS'
8879 !      include 'COMMON.TORSION'
8880 !      include 'COMMON.VAR'
8881 !      include 'COMMON.GEO'
8882       real(kind=8),dimension(2) :: vv,vv1
8883       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
8884       logical :: swap
8885 !el      logical :: lprn
8886 !el      common /kutas/ lprn
8887       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
8888       real(kind=8) :: s1,s2,s3,s4,s5
8889 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8890 !                                                                              C
8891 !      Parallel       Antiparallel                                             C
8892 !                                                                              C
8893 !          o             o                                                     C
8894 !         /l\           /j\                                                    C
8895 !        /   \         /   \                                                   C
8896 !       /| o |         | o |\                                                  C
8897 !     \ j|/k\|  /   \  |/k\|l /                                                C
8898 !      \ /   \ /     \ /   \ /                                                 C
8899 !       o     o       o     o                                                  C
8900 !       i             i                                                        C
8901 !                                                                              C
8902 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8903       itk=itortyp(itype(k))
8904       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8905       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8906       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8907       call transpose2(EUgC(1,1,k),auxmat(1,1))
8908       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8909       vv1(1)=pizda1(1,1)-pizda1(2,2)
8910       vv1(2)=pizda1(1,2)+pizda1(2,1)
8911       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8912       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8913       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8914       s5=scalar2(vv(1),Dtobr2(1,i))
8915 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8916       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8917       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
8918        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
8919        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
8920        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
8921        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
8922        +scalar2(vv(1),Dtobr2der(1,i)))
8923       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8924       vv1(1)=pizda1(1,1)-pizda1(2,2)
8925       vv1(2)=pizda1(1,2)+pizda1(2,1)
8926       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8927       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8928       if (l.eq.j+1) then
8929         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
8930        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8931        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8932        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8933        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8934       else
8935         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
8936        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
8937        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
8938        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
8939        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8940       endif
8941       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8942       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8943       vv1(1)=pizda1(1,1)-pizda1(2,2)
8944       vv1(2)=pizda1(1,2)+pizda1(2,1)
8945       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
8946        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
8947        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
8948        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8949       do iii=1,2
8950         if (swap) then
8951           ind=3-iii
8952         else
8953           ind=iii
8954         endif
8955         do kkk=1,5
8956           do lll=1,3
8957             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8958             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8959             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8960             call transpose2(EUgC(1,1,k),auxmat(1,1))
8961             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
8962               pizda1(1,1))
8963             vv1(1)=pizda1(1,1)-pizda1(2,2)
8964             vv1(2)=pizda1(1,2)+pizda1(2,1)
8965             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8966             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
8967              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8968             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
8969              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8970             s5=scalar2(vv(1),Dtobr2(1,i))
8971             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8972           enddo
8973         enddo
8974       enddo
8975       return
8976       end function eello6_graph1
8977 !-----------------------------------------------------------------------------
8978       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
8979       use comm_kut
8980 !      implicit real*8 (a-h,o-z)
8981 !      include 'DIMENSIONS'
8982 !      include 'COMMON.IOUNITS'
8983 !      include 'COMMON.CHAIN'
8984 !      include 'COMMON.DERIV'
8985 !      include 'COMMON.INTERACT'
8986 !      include 'COMMON.CONTACTS'
8987 !      include 'COMMON.TORSION'
8988 !      include 'COMMON.VAR'
8989 !      include 'COMMON.GEO'
8990       logical :: swap
8991       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
8992       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8993 !el      logical :: lprn
8994 !el      common /kutas/ lprn
8995       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
8996       real(kind=8) :: s2,s3,s4
8997 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8998 !                                                                              C
8999 !      Parallel       Antiparallel                                             C
9000 !                                                                              C
9001 !          o             o                                                     C
9002 !     \   /l\           /j\   /                                                C
9003 !      \ /   \         /   \ /                                                 C
9004 !       o| o |         | o |o                                                  C
9005 !     \ j|/k\|      \  |/k\|l                                                  C
9006 !      \ /   \       \ /   \                                                   C
9007 !       o             o                                                        C
9008 !       i             i                                                        C
9009 !                                                                              C
9010 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9011 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9012 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9013 !           but not in a cluster cumulant
9014 #ifdef MOMENT
9015       s1=dip(1,jj,i)*dip(1,kk,k)
9016 #endif
9017       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9018       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9019       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9020       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9021       call transpose2(EUg(1,1,k),auxmat(1,1))
9022       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9023       vv(1)=pizda(1,1)-pizda(2,2)
9024       vv(2)=pizda(1,2)+pizda(2,1)
9025       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9026 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9027 #ifdef MOMENT
9028       eello6_graph2=-(s1+s2+s3+s4)
9029 #else
9030       eello6_graph2=-(s2+s3+s4)
9031 #endif
9032 !      eello6_graph2=-s3
9033 ! Derivatives in gamma(i-1)
9034       if (i.gt.1) then
9035 #ifdef MOMENT
9036         s1=dipderg(1,jj,i)*dip(1,kk,k)
9037 #endif
9038         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9039         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9040         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9041         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9042 #ifdef MOMENT
9043         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9044 #else
9045         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9046 #endif
9047 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9048       endif
9049 ! Derivatives in gamma(k-1)
9050 #ifdef MOMENT
9051       s1=dip(1,jj,i)*dipderg(1,kk,k)
9052 #endif
9053       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9054       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9055       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9056       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9057       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9058       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9059       vv(1)=pizda(1,1)-pizda(2,2)
9060       vv(2)=pizda(1,2)+pizda(2,1)
9061       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9062 #ifdef MOMENT
9063       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9064 #else
9065       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9066 #endif
9067 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9068 ! Derivatives in gamma(j-1) or gamma(l-1)
9069       if (j.gt.1) then
9070 #ifdef MOMENT
9071         s1=dipderg(3,jj,i)*dip(1,kk,k)
9072 #endif
9073         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9074         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9075         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9076         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9077         vv(1)=pizda(1,1)-pizda(2,2)
9078         vv(2)=pizda(1,2)+pizda(2,1)
9079         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9080 #ifdef MOMENT
9081         if (swap) then
9082           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9083         else
9084           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9085         endif
9086 #endif
9087         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9088 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9089       endif
9090 ! Derivatives in gamma(l-1) or gamma(j-1)
9091       if (l.gt.1) then
9092 #ifdef MOMENT
9093         s1=dip(1,jj,i)*dipderg(3,kk,k)
9094 #endif
9095         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9096         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9097         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9098         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9099         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9100         vv(1)=pizda(1,1)-pizda(2,2)
9101         vv(2)=pizda(1,2)+pizda(2,1)
9102         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9103 #ifdef MOMENT
9104         if (swap) then
9105           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9106         else
9107           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9108         endif
9109 #endif
9110         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9111 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9112       endif
9113 ! Cartesian derivatives.
9114       if (lprn) then
9115         write (2,*) 'In eello6_graph2'
9116         do iii=1,2
9117           write (2,*) 'iii=',iii
9118           do kkk=1,5
9119             write (2,*) 'kkk=',kkk
9120             do jjj=1,2
9121               write (2,'(3(2f10.5),5x)') &
9122               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9123             enddo
9124           enddo
9125         enddo
9126       endif
9127       do iii=1,2
9128         do kkk=1,5
9129           do lll=1,3
9130 #ifdef MOMENT
9131             if (iii.eq.1) then
9132               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9133             else
9134               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9135             endif
9136 #endif
9137             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9138               auxvec(1))
9139             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9140             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9141               auxvec(1))
9142             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9143             call transpose2(EUg(1,1,k),auxmat(1,1))
9144             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9145               pizda(1,1))
9146             vv(1)=pizda(1,1)-pizda(2,2)
9147             vv(2)=pizda(1,2)+pizda(2,1)
9148             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9149 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9150 #ifdef MOMENT
9151             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9152 #else
9153             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9154 #endif
9155             if (swap) then
9156               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9157             else
9158               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9159             endif
9160           enddo
9161         enddo
9162       enddo
9163       return
9164       end function eello6_graph2
9165 !-----------------------------------------------------------------------------
9166       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9167 !      implicit real*8 (a-h,o-z)
9168 !      include 'DIMENSIONS'
9169 !      include 'COMMON.IOUNITS'
9170 !      include 'COMMON.CHAIN'
9171 !      include 'COMMON.DERIV'
9172 !      include 'COMMON.INTERACT'
9173 !      include 'COMMON.CONTACTS'
9174 !      include 'COMMON.TORSION'
9175 !      include 'COMMON.VAR'
9176 !      include 'COMMON.GEO'
9177       real(kind=8),dimension(2) :: vv,auxvec
9178       real(kind=8),dimension(2,2) :: pizda,auxmat
9179       logical :: swap
9180       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9181       real(kind=8) :: s1,s2,s3,s4
9182 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9183 !                                                                              C
9184 !      Parallel       Antiparallel                                             C
9185 !                                                                              C
9186 !          o             o                                                     C
9187 !         /l\   /   \   /j\                                                    C
9188 !        /   \ /     \ /   \                                                   C
9189 !       /| o |o       o| o |\                                                  C
9190 !       j|/k\|  /      |/k\|l /                                                C
9191 !        /   \ /       /   \ /                                                 C
9192 !       /     o       /     o                                                  C
9193 !       i             i                                                        C
9194 !                                                                              C
9195 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9196 !
9197 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9198 !           energy moment and not to the cluster cumulant.
9199       iti=itortyp(itype(i))
9200       if (j.lt.nres-1) then
9201         itj1=itortyp(itype(j+1))
9202       else
9203         itj1=ntortyp+1
9204       endif
9205       itk=itortyp(itype(k))
9206       itk1=itortyp(itype(k+1))
9207       if (l.lt.nres-1) then
9208         itl1=itortyp(itype(l+1))
9209       else
9210         itl1=ntortyp+1
9211       endif
9212 #ifdef MOMENT
9213       s1=dip(4,jj,i)*dip(4,kk,k)
9214 #endif
9215       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9216       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9217       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9218       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9219       call transpose2(EE(1,1,itk),auxmat(1,1))
9220       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9221       vv(1)=pizda(1,1)+pizda(2,2)
9222       vv(2)=pizda(2,1)-pizda(1,2)
9223       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9224 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9225 !d     & "sum",-(s2+s3+s4)
9226 #ifdef MOMENT
9227       eello6_graph3=-(s1+s2+s3+s4)
9228 #else
9229       eello6_graph3=-(s2+s3+s4)
9230 #endif
9231 !      eello6_graph3=-s4
9232 ! Derivatives in gamma(k-1)
9233       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9234       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9235       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9236       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9237 ! Derivatives in gamma(l-1)
9238       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9239       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9240       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9241       vv(1)=pizda(1,1)+pizda(2,2)
9242       vv(2)=pizda(2,1)-pizda(1,2)
9243       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9244       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9245 ! Cartesian derivatives.
9246       do iii=1,2
9247         do kkk=1,5
9248           do lll=1,3
9249 #ifdef MOMENT
9250             if (iii.eq.1) then
9251               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9252             else
9253               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9254             endif
9255 #endif
9256             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9257               auxvec(1))
9258             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9259             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9260               auxvec(1))
9261             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9262             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9263               pizda(1,1))
9264             vv(1)=pizda(1,1)+pizda(2,2)
9265             vv(2)=pizda(2,1)-pizda(1,2)
9266             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9267 #ifdef MOMENT
9268             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9269 #else
9270             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9271 #endif
9272             if (swap) then
9273               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9274             else
9275               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9276             endif
9277 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9278           enddo
9279         enddo
9280       enddo
9281       return
9282       end function eello6_graph3
9283 !-----------------------------------------------------------------------------
9284       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9285 !      implicit real*8 (a-h,o-z)
9286 !      include 'DIMENSIONS'
9287 !      include 'COMMON.IOUNITS'
9288 !      include 'COMMON.CHAIN'
9289 !      include 'COMMON.DERIV'
9290 !      include 'COMMON.INTERACT'
9291 !      include 'COMMON.CONTACTS'
9292 !      include 'COMMON.TORSION'
9293 !      include 'COMMON.VAR'
9294 !      include 'COMMON.GEO'
9295 !      include 'COMMON.FFIELD'
9296       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9297       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9298       logical :: swap
9299       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9300               iii,kkk,lll
9301       real(kind=8) :: s1,s2,s3,s4
9302 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9303 !                                                                              C
9304 !      Parallel       Antiparallel                                             C
9305 !                                                                              C
9306 !          o             o                                                     C
9307 !         /l\   /   \   /j\                                                    C
9308 !        /   \ /     \ /   \                                                   C
9309 !       /| o |o       o| o |\                                                  C
9310 !     \ j|/k\|      \  |/k\|l                                                  C
9311 !      \ /   \       \ /   \                                                   C
9312 !       o     \       o     \                                                  C
9313 !       i             i                                                        C
9314 !                                                                              C
9315 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9316 !
9317 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9318 !           energy moment and not to the cluster cumulant.
9319 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9320       iti=itortyp(itype(i))
9321       itj=itortyp(itype(j))
9322       if (j.lt.nres-1) then
9323         itj1=itortyp(itype(j+1))
9324       else
9325         itj1=ntortyp+1
9326       endif
9327       itk=itortyp(itype(k))
9328       if (k.lt.nres-1) then
9329         itk1=itortyp(itype(k+1))
9330       else
9331         itk1=ntortyp+1
9332       endif
9333       itl=itortyp(itype(l))
9334       if (l.lt.nres-1) then
9335         itl1=itortyp(itype(l+1))
9336       else
9337         itl1=ntortyp+1
9338       endif
9339 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9340 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9341 !d     & ' itl',itl,' itl1',itl1
9342 #ifdef MOMENT
9343       if (imat.eq.1) then
9344         s1=dip(3,jj,i)*dip(3,kk,k)
9345       else
9346         s1=dip(2,jj,j)*dip(2,kk,l)
9347       endif
9348 #endif
9349       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9350       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9351       if (j.eq.l+1) then
9352         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9353         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9354       else
9355         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9356         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9357       endif
9358       call transpose2(EUg(1,1,k),auxmat(1,1))
9359       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9360       vv(1)=pizda(1,1)-pizda(2,2)
9361       vv(2)=pizda(2,1)+pizda(1,2)
9362       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9363 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9364 #ifdef MOMENT
9365       eello6_graph4=-(s1+s2+s3+s4)
9366 #else
9367       eello6_graph4=-(s2+s3+s4)
9368 #endif
9369 ! Derivatives in gamma(i-1)
9370       if (i.gt.1) then
9371 #ifdef MOMENT
9372         if (imat.eq.1) then
9373           s1=dipderg(2,jj,i)*dip(3,kk,k)
9374         else
9375           s1=dipderg(4,jj,j)*dip(2,kk,l)
9376         endif
9377 #endif
9378         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9379         if (j.eq.l+1) then
9380           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9381           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9382         else
9383           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9384           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9385         endif
9386         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9387         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9388 !d          write (2,*) 'turn6 derivatives'
9389 #ifdef MOMENT
9390           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9391 #else
9392           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9393 #endif
9394         else
9395 #ifdef MOMENT
9396           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9397 #else
9398           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9399 #endif
9400         endif
9401       endif
9402 ! Derivatives in gamma(k-1)
9403 #ifdef MOMENT
9404       if (imat.eq.1) then
9405         s1=dip(3,jj,i)*dipderg(2,kk,k)
9406       else
9407         s1=dip(2,jj,j)*dipderg(4,kk,l)
9408       endif
9409 #endif
9410       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9411       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9412       if (j.eq.l+1) then
9413         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9414         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9415       else
9416         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9417         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9418       endif
9419       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9420       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9421       vv(1)=pizda(1,1)-pizda(2,2)
9422       vv(2)=pizda(2,1)+pizda(1,2)
9423       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9424       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9425 #ifdef MOMENT
9426         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9427 #else
9428         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9429 #endif
9430       else
9431 #ifdef MOMENT
9432         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9433 #else
9434         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9435 #endif
9436       endif
9437 ! Derivatives in gamma(j-1) or gamma(l-1)
9438       if (l.eq.j+1 .and. l.gt.1) then
9439         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9440         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9441         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9442         vv(1)=pizda(1,1)-pizda(2,2)
9443         vv(2)=pizda(2,1)+pizda(1,2)
9444         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9445         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9446       else if (j.gt.1) then
9447         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9448         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9449         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9450         vv(1)=pizda(1,1)-pizda(2,2)
9451         vv(2)=pizda(2,1)+pizda(1,2)
9452         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9453         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9454           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9455         else
9456           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9457         endif
9458       endif
9459 ! Cartesian derivatives.
9460       do iii=1,2
9461         do kkk=1,5
9462           do lll=1,3
9463 #ifdef MOMENT
9464             if (iii.eq.1) then
9465               if (imat.eq.1) then
9466                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9467               else
9468                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9469               endif
9470             else
9471               if (imat.eq.1) then
9472                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9473               else
9474                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9475               endif
9476             endif
9477 #endif
9478             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9479               auxvec(1))
9480             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9481             if (j.eq.l+1) then
9482               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9483                 b1(1,itj1),auxvec(1))
9484               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9485             else
9486               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9487                 b1(1,itl1),auxvec(1))
9488               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9489             endif
9490             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9491               pizda(1,1))
9492             vv(1)=pizda(1,1)-pizda(2,2)
9493             vv(2)=pizda(2,1)+pizda(1,2)
9494             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9495             if (swap) then
9496               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9497 #ifdef MOMENT
9498                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9499                    -(s1+s2+s4)
9500 #else
9501                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9502                    -(s2+s4)
9503 #endif
9504                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9505               else
9506 #ifdef MOMENT
9507                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9508 #else
9509                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9510 #endif
9511                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9512               endif
9513             else
9514 #ifdef MOMENT
9515               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9516 #else
9517               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9518 #endif
9519               if (l.eq.j+1) then
9520                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9521               else
9522                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9523               endif
9524             endif
9525           enddo
9526         enddo
9527       enddo
9528       return
9529       end function eello6_graph4
9530 !-----------------------------------------------------------------------------
9531       real(kind=8) function eello_turn6(i,jj,kk)
9532 !      implicit real*8 (a-h,o-z)
9533 !      include 'DIMENSIONS'
9534 !      include 'COMMON.IOUNITS'
9535 !      include 'COMMON.CHAIN'
9536 !      include 'COMMON.DERIV'
9537 !      include 'COMMON.INTERACT'
9538 !      include 'COMMON.CONTACTS'
9539 !      include 'COMMON.TORSION'
9540 !      include 'COMMON.VAR'
9541 !      include 'COMMON.GEO'
9542       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9543       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9544       real(kind=8),dimension(3) :: ggg1,ggg2
9545       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9546       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9547 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9548 !           the respective energy moment and not to the cluster cumulant.
9549 !el local variables
9550       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9551       integer :: j1,j2,l1,l2,ll
9552       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9553       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9554       s1=0.0d0
9555       s8=0.0d0
9556       s13=0.0d0
9557 !
9558       eello_turn6=0.0d0
9559       j=i+4
9560       k=i+1
9561       l=i+3
9562       iti=itortyp(itype(i))
9563       itk=itortyp(itype(k))
9564       itk1=itortyp(itype(k+1))
9565       itl=itortyp(itype(l))
9566       itj=itortyp(itype(j))
9567 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9568 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
9569 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9570 !d        eello6=0.0d0
9571 !d        return
9572 !d      endif
9573 !d      write (iout,*)
9574 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9575 !d     &   ' and',k,l
9576 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
9577       do iii=1,2
9578         do kkk=1,5
9579           do lll=1,3
9580             derx_turn(lll,kkk,iii)=0.0d0
9581           enddo
9582         enddo
9583       enddo
9584 !d      eij=1.0d0
9585 !d      ekl=1.0d0
9586 !d      ekont=1.0d0
9587       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9588 !d      eello6_5=0.0d0
9589 !d      write (2,*) 'eello6_5',eello6_5
9590 #ifdef MOMENT
9591       call transpose2(AEA(1,1,1),auxmat(1,1))
9592       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9593       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9594       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9595 #endif
9596       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9597       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9598       s2 = scalar2(b1(1,itk),vtemp1(1))
9599 #ifdef MOMENT
9600       call transpose2(AEA(1,1,2),atemp(1,1))
9601       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9602       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9603       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9604 #endif
9605       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9606       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9607       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9608 #ifdef MOMENT
9609       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9610       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9611       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9612       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9613       ss13 = scalar2(b1(1,itk),vtemp4(1))
9614       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9615 #endif
9616 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9617 !      s1=0.0d0
9618 !      s2=0.0d0
9619 !      s8=0.0d0
9620 !      s12=0.0d0
9621 !      s13=0.0d0
9622       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9623 ! Derivatives in gamma(i+2)
9624       s1d =0.0d0
9625       s8d =0.0d0
9626 #ifdef MOMENT
9627       call transpose2(AEA(1,1,1),auxmatd(1,1))
9628       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9629       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9630       call transpose2(AEAderg(1,1,2),atempd(1,1))
9631       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9632       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9633 #endif
9634       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9635       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9636       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9637 !      s1d=0.0d0
9638 !      s2d=0.0d0
9639 !      s8d=0.0d0
9640 !      s12d=0.0d0
9641 !      s13d=0.0d0
9642       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9643 ! Derivatives in gamma(i+3)
9644 #ifdef MOMENT
9645       call transpose2(AEA(1,1,1),auxmatd(1,1))
9646       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9647       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9648       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9649 #endif
9650       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9651       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9652       s2d = scalar2(b1(1,itk),vtemp1d(1))
9653 #ifdef MOMENT
9654       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9655       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9656 #endif
9657       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9658 #ifdef MOMENT
9659       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9660       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9661       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9662 #endif
9663 !      s1d=0.0d0
9664 !      s2d=0.0d0
9665 !      s8d=0.0d0
9666 !      s12d=0.0d0
9667 !      s13d=0.0d0
9668 #ifdef MOMENT
9669       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9670                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9671 #else
9672       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9673                     -0.5d0*ekont*(s2d+s12d)
9674 #endif
9675 ! Derivatives in gamma(i+4)
9676       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9677       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9678       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9679 #ifdef MOMENT
9680       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9681       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9682       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9683 #endif
9684 !      s1d=0.0d0
9685 !      s2d=0.0d0
9686 !      s8d=0.0d0
9687 !      s12d=0.0d0
9688 !      s13d=0.0d0
9689 #ifdef MOMENT
9690       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9691 #else
9692       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9693 #endif
9694 ! Derivatives in gamma(i+5)
9695 #ifdef MOMENT
9696       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9697       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9698       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9699 #endif
9700       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9701       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9702       s2d = scalar2(b1(1,itk),vtemp1d(1))
9703 #ifdef MOMENT
9704       call transpose2(AEA(1,1,2),atempd(1,1))
9705       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9706       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9707 #endif
9708       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9709       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9710 #ifdef MOMENT
9711       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9712       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9713       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9714 #endif
9715 !      s1d=0.0d0
9716 !      s2d=0.0d0
9717 !      s8d=0.0d0
9718 !      s12d=0.0d0
9719 !      s13d=0.0d0
9720 #ifdef MOMENT
9721       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9722                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9723 #else
9724       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
9725                     -0.5d0*ekont*(s2d+s12d)
9726 #endif
9727 ! Cartesian derivatives
9728       do iii=1,2
9729         do kkk=1,5
9730           do lll=1,3
9731 #ifdef MOMENT
9732             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9733             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9734             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9735 #endif
9736             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9737             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
9738                 vtemp1d(1))
9739             s2d = scalar2(b1(1,itk),vtemp1d(1))
9740 #ifdef MOMENT
9741             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9742             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9743             s8d = -(atempd(1,1)+atempd(2,2))* &
9744                  scalar2(cc(1,1,itl),vtemp2(1))
9745 #endif
9746             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
9747                  auxmatd(1,1))
9748             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9749             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9750 !      s1d=0.0d0
9751 !      s2d=0.0d0
9752 !      s8d=0.0d0
9753 !      s12d=0.0d0
9754 !      s13d=0.0d0
9755 #ifdef MOMENT
9756             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9757               - 0.5d0*(s1d+s2d)
9758 #else
9759             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
9760               - 0.5d0*s2d
9761 #endif
9762 #ifdef MOMENT
9763             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9764               - 0.5d0*(s8d+s12d)
9765 #else
9766             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
9767               - 0.5d0*s12d
9768 #endif
9769           enddo
9770         enddo
9771       enddo
9772 #ifdef MOMENT
9773       do kkk=1,5
9774         do lll=1,3
9775           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
9776             achuj_tempd(1,1))
9777           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9778           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9779           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9780           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9781           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
9782             vtemp4d(1))
9783           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9784           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9785           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9786         enddo
9787       enddo
9788 #endif
9789 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9790 !d     &  16*eel_turn6_num
9791 !d      goto 1112
9792       if (j.lt.nres-1) then
9793         j1=j+1
9794         j2=j-1
9795       else
9796         j1=j-1
9797         j2=j-2
9798       endif
9799       if (l.lt.nres-1) then
9800         l1=l+1
9801         l2=l-1
9802       else
9803         l1=l-1
9804         l2=l-2
9805       endif
9806       do ll=1,3
9807 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9808 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9809 !grad        ghalf=0.5d0*ggg1(ll)
9810 !d        ghalf=0.0d0
9811         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9812         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9813         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
9814           +ekont*derx_turn(ll,2,1)
9815         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9816         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
9817           +ekont*derx_turn(ll,4,1)
9818         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9819         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9820         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9821 !grad        ghalf=0.5d0*ggg2(ll)
9822 !d        ghalf=0.0d0
9823         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
9824           +ekont*derx_turn(ll,2,2)
9825         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9826         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
9827           +ekont*derx_turn(ll,4,2)
9828         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9829         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9830         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9831       enddo
9832 !d      goto 1112
9833 !grad      do m=i+1,j-1
9834 !grad        do ll=1,3
9835 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9836 !grad        enddo
9837 !grad      enddo
9838 !grad      do m=k+1,l-1
9839 !grad        do ll=1,3
9840 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9841 !grad        enddo
9842 !grad      enddo
9843 !grad1112  continue
9844 !grad      do m=i+2,j2
9845 !grad        do ll=1,3
9846 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9847 !grad        enddo
9848 !grad      enddo
9849 !grad      do m=k+2,l2
9850 !grad        do ll=1,3
9851 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9852 !grad        enddo
9853 !grad      enddo
9854 !d      do iii=1,nres-3
9855 !d        write (2,*) iii,g_corr6_loc(iii)
9856 !d      enddo
9857       eello_turn6=ekont*eel_turn6
9858 !d      write (2,*) 'ekont',ekont
9859 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
9860       return
9861       end function eello_turn6
9862 !-----------------------------------------------------------------------------
9863       subroutine MATVEC2(A1,V1,V2)
9864 !DIR$ INLINEALWAYS MATVEC2
9865 #ifndef OSF
9866 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9867 #endif
9868 !      implicit real*8 (a-h,o-z)
9869 !      include 'DIMENSIONS'
9870       real(kind=8),dimension(2) :: V1,V2
9871       real(kind=8),dimension(2,2) :: A1
9872       real(kind=8) :: vaux1,vaux2
9873 !      DO 1 I=1,2
9874 !        VI=0.0
9875 !        DO 3 K=1,2
9876 !    3     VI=VI+A1(I,K)*V1(K)
9877 !        Vaux(I)=VI
9878 !    1 CONTINUE
9879
9880       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9881       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9882
9883       v2(1)=vaux1
9884       v2(2)=vaux2
9885       end subroutine MATVEC2
9886 !-----------------------------------------------------------------------------
9887       subroutine MATMAT2(A1,A2,A3)
9888 #ifndef OSF
9889 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9890 #endif
9891 !      implicit real*8 (a-h,o-z)
9892 !      include 'DIMENSIONS'
9893       real(kind=8),dimension(2,2) :: A1,A2,A3
9894       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
9895 !      DIMENSION AI3(2,2)
9896 !        DO  J=1,2
9897 !          A3IJ=0.0
9898 !          DO K=1,2
9899 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9900 !          enddo
9901 !          A3(I,J)=A3IJ
9902 !       enddo
9903 !      enddo
9904
9905       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9906       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9907       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9908       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9909
9910       A3(1,1)=AI3_11
9911       A3(2,1)=AI3_21
9912       A3(1,2)=AI3_12
9913       A3(2,2)=AI3_22
9914       end subroutine MATMAT2
9915 !-----------------------------------------------------------------------------
9916       real(kind=8) function scalar2(u,v)
9917 !DIR$ INLINEALWAYS scalar2
9918       implicit none
9919       real(kind=8),dimension(2) :: u,v
9920       real(kind=8) :: sc
9921       integer :: i
9922       scalar2=u(1)*v(1)+u(2)*v(2)
9923       return
9924       end function scalar2
9925 !-----------------------------------------------------------------------------
9926       subroutine transpose2(a,at)
9927 !DIR$ INLINEALWAYS transpose2
9928 #ifndef OSF
9929 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
9930 #endif
9931       implicit none
9932       real(kind=8),dimension(2,2) :: a,at
9933       at(1,1)=a(1,1)
9934       at(1,2)=a(2,1)
9935       at(2,1)=a(1,2)
9936       at(2,2)=a(2,2)
9937       return
9938       end subroutine transpose2
9939 !-----------------------------------------------------------------------------
9940       subroutine transpose(n,a,at)
9941       implicit none
9942       integer :: n,i,j
9943       real(kind=8),dimension(n,n) :: a,at
9944       do i=1,n
9945         do j=1,n
9946           at(j,i)=a(i,j)
9947         enddo
9948       enddo
9949       return
9950       end subroutine transpose
9951 !-----------------------------------------------------------------------------
9952       subroutine prodmat3(a1,a2,kk,transp,prod)
9953 !DIR$ INLINEALWAYS prodmat3
9954 #ifndef OSF
9955 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
9956 #endif
9957       implicit none
9958       integer :: i,j
9959       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
9960       logical :: transp
9961 !rc      double precision auxmat(2,2),prod_(2,2)
9962
9963       if (transp) then
9964 !rc        call transpose2(kk(1,1),auxmat(1,1))
9965 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9966 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9967
9968            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
9969        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9970            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
9971        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9972            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
9973        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9974            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
9975        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9976
9977       else
9978 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9979 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9980
9981            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
9982         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9983            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
9984         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9985            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
9986         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9987            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
9988         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9989
9990       endif
9991 !      call transpose2(a2(1,1),a2t(1,1))
9992
9993 !rc      print *,transp
9994 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
9995 !rc      print *,((prod(i,j),i=1,2),j=1,2)
9996
9997       return
9998       end subroutine prodmat3
9999 !-----------------------------------------------------------------------------
10000 ! energy_p_new_barrier.F
10001 !-----------------------------------------------------------------------------
10002       subroutine sum_gradient
10003 !      implicit real*8 (a-h,o-z)
10004       use io_base, only: pdbout
10005 !      include 'DIMENSIONS'
10006 #ifndef ISNAN
10007       external proc_proc
10008 #ifdef WINPGI
10009 !MS$ATTRIBUTES C ::  proc_proc
10010 #endif
10011 #endif
10012 #ifdef MPI
10013       include 'mpif.h'
10014 #endif
10015       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10016                    gloc_scbuf !(3,maxres)
10017
10018       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10019 !#endif
10020 !el local variables
10021       integer :: i,j,k,ierror,ierr
10022       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10023                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10024                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10025                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10026                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10027                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10028                    gsccorr_max,gsccorrx_max,time00
10029
10030 !      include 'COMMON.SETUP'
10031 !      include 'COMMON.IOUNITS'
10032 !      include 'COMMON.FFIELD'
10033 !      include 'COMMON.DERIV'
10034 !      include 'COMMON.INTERACT'
10035 !      include 'COMMON.SBRIDGE'
10036 !      include 'COMMON.CHAIN'
10037 !      include 'COMMON.VAR'
10038 !      include 'COMMON.CONTROL'
10039 !      include 'COMMON.TIME1'
10040 !      include 'COMMON.MAXGRAD'
10041 !      include 'COMMON.SCCOR'
10042 #ifdef TIMING
10043       time01=MPI_Wtime()
10044 #endif
10045 #ifdef DEBUG
10046       write (iout,*) "sum_gradient gvdwc, gvdwx"
10047       do i=1,nres
10048         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10049          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10050       enddo
10051       call flush(iout)
10052 #endif
10053 #ifdef MPI
10054         gradbufc=0.0d0
10055         gradbufx=0.0d0
10056         gradbufc_sum=0.0d0
10057         gloc_scbuf=0.0d0
10058         glocbuf=0.0d0
10059 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10060         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10061           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10062 #endif
10063 !
10064 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10065 !            in virtual-bond-vector coordinates
10066 !
10067 #ifdef DEBUG
10068 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10069 !      do i=1,nres-1
10070 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10071 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10072 !      enddo
10073 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10074 !      do i=1,nres-1
10075 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10076 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10077 !      enddo
10078       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10079       do i=1,nres
10080         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10081          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10082          (gvdwc_scpp(j,i),j=1,3)
10083       enddo
10084       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10085       do i=1,nres
10086         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10087          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10088          (gelc_loc_long(j,i),j=1,3)
10089       enddo
10090       call flush(iout)
10091 #endif
10092 #ifdef SPLITELE
10093       do i=0,nct
10094         do j=1,3
10095           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10096                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10097                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10098                       wel_loc*gel_loc_long(j,i)+ &
10099                       wcorr*gradcorr_long(j,i)+ &
10100                       wcorr5*gradcorr5_long(j,i)+ &
10101                       wcorr6*gradcorr6_long(j,i)+ &
10102                       wturn6*gcorr6_turn_long(j,i)+ &
10103                       wstrain*ghpbc(j,i) &
10104                      +wliptran*gliptranc(j,i) &
10105                      +welec*gshieldc(j,i) &
10106                      +wcorr*gshieldc_ec(j,i) &
10107                      +wturn3*gshieldc_t3(j,i)&
10108                      +wturn4*gshieldc_t4(j,i)&
10109                      +wel_loc*gshieldc_ll(j,i)
10110
10111
10112         enddo
10113       enddo
10114 #else
10115       do i=0,nct
10116         do j=1,3
10117           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10118                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10119                       welec*gelc_long(j,i)+ &
10120                       wbond*gradb(j,i)+ &
10121                       wel_loc*gel_loc_long(j,i)+ &
10122                       wcorr*gradcorr_long(j,i)+ &
10123                       wcorr5*gradcorr5_long(j,i)+ &
10124                       wcorr6*gradcorr6_long(j,i)+ &
10125                       wturn6*gcorr6_turn_long(j,i)+ &
10126                       wstrain*ghpbc(j,i) &
10127                      +wliptran*gliptranc(j,i) &
10128                      +welec*gshieldc(j,i)&
10129                      +wcorr*gshieldc_ec(j,i) &
10130                      +wturn4*gshieldc_t4(j,i) &
10131                      +wel_loc*gshieldc_ll(j,i)
10132
10133
10134         enddo
10135       enddo
10136 #endif
10137 #ifdef MPI
10138       if (nfgtasks.gt.1) then
10139       time00=MPI_Wtime()
10140 #ifdef DEBUG
10141       write (iout,*) "gradbufc before allreduce"
10142       do i=1,nres
10143         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10144       enddo
10145       call flush(iout)
10146 #endif
10147       do i=0,nres
10148         do j=1,3
10149           gradbufc_sum(j,i)=gradbufc(j,i)
10150         enddo
10151       enddo
10152 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10153 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10154 !      time_reduce=time_reduce+MPI_Wtime()-time00
10155 #ifdef DEBUG
10156 !      write (iout,*) "gradbufc_sum after allreduce"
10157 !      do i=1,nres
10158 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10159 !      enddo
10160 !      call flush(iout)
10161 #endif
10162 #ifdef TIMING
10163 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10164 #endif
10165       do i=0,nres
10166         do k=1,3
10167           gradbufc(k,i)=0.0d0
10168         enddo
10169       enddo
10170 #ifdef DEBUG
10171       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10172       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10173                         " jgrad_end  ",jgrad_end(i),&
10174                         i=igrad_start,igrad_end)
10175 #endif
10176 !
10177 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10178 ! do not parallelize this part.
10179 !
10180 !      do i=igrad_start,igrad_end
10181 !        do j=jgrad_start(i),jgrad_end(i)
10182 !          do k=1,3
10183 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10184 !          enddo
10185 !        enddo
10186 !      enddo
10187       do j=1,3
10188         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10189       enddo
10190       do i=nres-2,-1,-1
10191         do j=1,3
10192           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10193         enddo
10194       enddo
10195 #ifdef DEBUG
10196       write (iout,*) "gradbufc after summing"
10197       do i=1,nres
10198         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10199       enddo
10200       call flush(iout)
10201 #endif
10202       else
10203 #endif
10204 !el#define DEBUG
10205 #ifdef DEBUG
10206       write (iout,*) "gradbufc"
10207       do i=1,nres
10208         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10209       enddo
10210       call flush(iout)
10211 #endif
10212 !el#undef DEBUG
10213       do i=-1,nres
10214         do j=1,3
10215           gradbufc_sum(j,i)=gradbufc(j,i)
10216           gradbufc(j,i)=0.0d0
10217         enddo
10218       enddo
10219       do j=1,3
10220         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10221       enddo
10222       do i=nres-2,-1,-1
10223         do j=1,3
10224           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10225         enddo
10226       enddo
10227 !      do i=nnt,nres-1
10228 !        do k=1,3
10229 !          gradbufc(k,i)=0.0d0
10230 !        enddo
10231 !        do j=i+1,nres
10232 !          do k=1,3
10233 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10234 !          enddo
10235 !        enddo
10236 !      enddo
10237 !el#define DEBUG
10238 #ifdef DEBUG
10239       write (iout,*) "gradbufc after summing"
10240       do i=1,nres
10241         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10242       enddo
10243       call flush(iout)
10244 #endif
10245 !el#undef DEBUG
10246 #ifdef MPI
10247       endif
10248 #endif
10249       do k=1,3
10250         gradbufc(k,nres)=0.0d0
10251       enddo
10252 !el----------------
10253 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10254 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10255 !el-----------------
10256       do i=-1,nct
10257         do j=1,3
10258 #ifdef SPLITELE
10259           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10260                       wel_loc*gel_loc(j,i)+ &
10261                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10262                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10263                       wel_loc*gel_loc_long(j,i)+ &
10264                       wcorr*gradcorr_long(j,i)+ &
10265                       wcorr5*gradcorr5_long(j,i)+ &
10266                       wcorr6*gradcorr6_long(j,i)+ &
10267                       wturn6*gcorr6_turn_long(j,i))+ &
10268                       wbond*gradb(j,i)+ &
10269                       wcorr*gradcorr(j,i)+ &
10270                       wturn3*gcorr3_turn(j,i)+ &
10271                       wturn4*gcorr4_turn(j,i)+ &
10272                       wcorr5*gradcorr5(j,i)+ &
10273                       wcorr6*gradcorr6(j,i)+ &
10274                       wturn6*gcorr6_turn(j,i)+ &
10275                       wsccor*gsccorc(j,i) &
10276                      +wscloc*gscloc(j,i)  &
10277                      +wliptran*gliptranc(j,i) &
10278                      +welec*gshieldc(j,i) &
10279                      +welec*gshieldc_loc(j,i) &
10280                      +wcorr*gshieldc_ec(j,i) &
10281                      +wcorr*gshieldc_loc_ec(j,i) &
10282                      +wturn3*gshieldc_t3(j,i) &
10283                      +wturn3*gshieldc_loc_t3(j,i) &
10284                      +wturn4*gshieldc_t4(j,i) &
10285                      +wturn4*gshieldc_loc_t4(j,i) &
10286                      +wel_loc*gshieldc_ll(j,i) &
10287                      +wel_loc*gshieldc_loc_ll(j,i)
10288
10289 #else
10290           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10291                       wel_loc*gel_loc(j,i)+ &
10292                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10293                       welec*gelc_long(j,i)+ &
10294                       wel_loc*gel_loc_long(j,i)+ &
10295 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10296                       wcorr5*gradcorr5_long(j,i)+ &
10297                       wcorr6*gradcorr6_long(j,i)+ &
10298                       wturn6*gcorr6_turn_long(j,i))+ &
10299                       wbond*gradb(j,i)+ &
10300                       wcorr*gradcorr(j,i)+ &
10301                       wturn3*gcorr3_turn(j,i)+ &
10302                       wturn4*gcorr4_turn(j,i)+ &
10303                       wcorr5*gradcorr5(j,i)+ &
10304                       wcorr6*gradcorr6(j,i)+ &
10305                       wturn6*gcorr6_turn(j,i)+ &
10306                       wsccor*gsccorc(j,i) &
10307                      +wscloc*gscloc(j,i) &
10308                      +wliptran*gliptranc(j,i) &
10309                      +welec*gshieldc(j,i) &
10310                      +welec*gshieldc_loc(j,) &
10311                      +wcorr*gshieldc_ec(j,i) &
10312                      +wcorr*gshieldc_loc_ec(j,i) &
10313                      +wturn3*gshieldc_t3(j,i) &
10314                      +wturn3*gshieldc_loc_t3(j,i) &
10315                      +wturn4*gshieldc_t4(j,i) &
10316                      +wturn4*gshieldc_loc_t4(j,i) &
10317                      +wel_loc*gshieldc_ll(j,i) &
10318                      +wel_loc*gshieldc_loc_ll(j,i)
10319
10320
10321 #endif
10322           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10323                         wbond*gradbx(j,i)+ &
10324                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10325                         wsccor*gsccorx(j,i) &
10326                        +wscloc*gsclocx(j,i) &
10327                        +wliptran*gliptranx(j,i) &
10328                        +welec*gshieldx(j,i)     &
10329                        +wcorr*gshieldx_ec(j,i)  &
10330                        +wturn3*gshieldx_t3(j,i) &
10331                        +wturn4*gshieldx_t4(j,i) &
10332                        +wel_loc*gshieldx_ll(j,i)
10333
10334         enddo
10335       enddo
10336 #ifdef DEBUG
10337       write (iout,*) "gloc before adding corr"
10338       do i=1,4*nres
10339         write (iout,*) i,gloc(i,icg)
10340       enddo
10341 #endif
10342       do i=1,nres-3
10343         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10344          +wcorr5*g_corr5_loc(i) &
10345          +wcorr6*g_corr6_loc(i) &
10346          +wturn4*gel_loc_turn4(i) &
10347          +wturn3*gel_loc_turn3(i) &
10348          +wturn6*gel_loc_turn6(i) &
10349          +wel_loc*gel_loc_loc(i)
10350       enddo
10351 #ifdef DEBUG
10352       write (iout,*) "gloc after adding corr"
10353       do i=1,4*nres
10354         write (iout,*) i,gloc(i,icg)
10355       enddo
10356 #endif
10357 #ifdef MPI
10358       if (nfgtasks.gt.1) then
10359         do j=1,3
10360           do i=1,nres
10361             gradbufc(j,i)=gradc(j,i,icg)
10362             gradbufx(j,i)=gradx(j,i,icg)
10363           enddo
10364         enddo
10365         do i=1,4*nres
10366           glocbuf(i)=gloc(i,icg)
10367         enddo
10368 !#define DEBUG
10369 #ifdef DEBUG
10370       write (iout,*) "gloc_sc before reduce"
10371       do i=1,nres
10372        do j=1,1
10373         write (iout,*) i,j,gloc_sc(j,i,icg)
10374        enddo
10375       enddo
10376 #endif
10377 !#undef DEBUG
10378         do i=1,nres
10379          do j=1,3
10380           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10381          enddo
10382         enddo
10383         time00=MPI_Wtime()
10384         call MPI_Barrier(FG_COMM,IERR)
10385         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10386         time00=MPI_Wtime()
10387         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,&
10388           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10389         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
10390           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10391         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10392           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10393         time_reduce=time_reduce+MPI_Wtime()-time00
10394         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10395           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10396         time_reduce=time_reduce+MPI_Wtime()-time00
10397 !#define DEBUG
10398 #ifdef DEBUG
10399       write (iout,*) "gloc_sc after reduce"
10400       do i=1,nres
10401        do j=1,1
10402         write (iout,*) i,j,gloc_sc(j,i,icg)
10403        enddo
10404       enddo
10405 #endif
10406 !#undef DEBUG
10407 #ifdef DEBUG
10408       write (iout,*) "gloc after reduce"
10409       do i=1,4*nres
10410         write (iout,*) i,gloc(i,icg)
10411       enddo
10412 #endif
10413       endif
10414 #endif
10415       if (gnorm_check) then
10416 !
10417 ! Compute the maximum elements of the gradient
10418 !
10419       gvdwc_max=0.0d0
10420       gvdwc_scp_max=0.0d0
10421       gelc_max=0.0d0
10422       gvdwpp_max=0.0d0
10423       gradb_max=0.0d0
10424       ghpbc_max=0.0d0
10425       gradcorr_max=0.0d0
10426       gel_loc_max=0.0d0
10427       gcorr3_turn_max=0.0d0
10428       gcorr4_turn_max=0.0d0
10429       gradcorr5_max=0.0d0
10430       gradcorr6_max=0.0d0
10431       gcorr6_turn_max=0.0d0
10432       gsccorc_max=0.0d0
10433       gscloc_max=0.0d0
10434       gvdwx_max=0.0d0
10435       gradx_scp_max=0.0d0
10436       ghpbx_max=0.0d0
10437       gradxorr_max=0.0d0
10438       gsccorx_max=0.0d0
10439       gsclocx_max=0.0d0
10440       do i=1,nct
10441         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10442         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10443         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10444         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10445          gvdwc_scp_max=gvdwc_scp_norm
10446         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10447         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10448         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10449         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10450         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10451         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10452         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10453         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10454         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10455         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10456         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10457         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10458         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10459           gcorr3_turn(1,i)))
10460         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10461           gcorr3_turn_max=gcorr3_turn_norm
10462         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10463           gcorr4_turn(1,i)))
10464         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10465           gcorr4_turn_max=gcorr4_turn_norm
10466         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10467         if (gradcorr5_norm.gt.gradcorr5_max) &
10468           gradcorr5_max=gradcorr5_norm
10469         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10470         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10471         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10472           gcorr6_turn(1,i)))
10473         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10474           gcorr6_turn_max=gcorr6_turn_norm
10475         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
10476         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
10477         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
10478         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
10479         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
10480         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
10481         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
10482         if (gradx_scp_norm.gt.gradx_scp_max) &
10483           gradx_scp_max=gradx_scp_norm
10484         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
10485         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
10486         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
10487         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
10488         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
10489         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
10490         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
10491         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
10492       enddo
10493       if (gradout) then
10494 #ifdef AIX
10495         open(istat,file=statname,position="append")
10496 #else
10497         open(istat,file=statname,access="append")
10498 #endif
10499         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
10500            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
10501            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
10502            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
10503            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
10504            gsccorx_max,gsclocx_max
10505         close(istat)
10506         if (gvdwc_max.gt.1.0d4) then
10507           write (iout,*) "gvdwc gvdwx gradb gradbx"
10508           do i=nnt,nct
10509             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
10510               gradb(j,i),gradbx(j,i),j=1,3)
10511           enddo
10512           call pdbout(0.0d0,'cipiszcze',iout)
10513           call flush(iout)
10514         endif
10515       endif
10516       endif
10517 !el#define DEBUG
10518 #ifdef DEBUG
10519       write (iout,*) "gradc gradx gloc"
10520       do i=1,nres
10521         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
10522          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
10523       enddo
10524 #endif
10525 !el#undef DEBUG
10526 #ifdef TIMING
10527       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
10528 #endif
10529       return
10530       end subroutine sum_gradient
10531 !-----------------------------------------------------------------------------
10532       subroutine sc_grad
10533 !      implicit real*8 (a-h,o-z)
10534       use calc_data
10535 !      include 'DIMENSIONS'
10536 !      include 'COMMON.CHAIN'
10537 !      include 'COMMON.DERIV'
10538 !      include 'COMMON.CALC'
10539 !      include 'COMMON.IOUNITS'
10540       real(kind=8), dimension(3) :: dcosom1,dcosom2
10541
10542       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
10543       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
10544       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
10545            -2.0D0*alf12*eps3der+sigder*sigsq_om12
10546 ! diagnostics only
10547 !      eom1=0.0d0
10548 !      eom2=0.0d0
10549 !      eom12=evdwij*eps1_om12
10550 ! end diagnostics
10551 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
10552 !       " sigder",sigder
10553 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
10554 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
10555 !C      print *,sss_ele_cut,'in sc_grad'
10556       do k=1,3
10557         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
10558         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
10559       enddo
10560       do k=1,3
10561         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
10562 !C      print *,'gg',k,gg(k)
10563       enddo
10564 !      write (iout,*) "gg",(gg(k),k=1,3)
10565       do k=1,3
10566         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
10567                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10568                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
10569                   *sss_ele_cut
10570
10571         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
10572                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10573                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
10574                   *sss_ele_cut
10575
10576 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10577 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
10578 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10579 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
10580       enddo
10581 !
10582 ! Calculate the components of the gradient in DC and X
10583 !
10584 !grad      do k=i,j-1
10585 !grad        do l=1,3
10586 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
10587 !grad        enddo
10588 !grad      enddo
10589       do l=1,3
10590         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
10591         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
10592       enddo
10593       return
10594       end subroutine sc_grad
10595 #ifdef CRYST_THETA
10596 !-----------------------------------------------------------------------------
10597       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
10598
10599       use comm_calcthet
10600 !      implicit real*8 (a-h,o-z)
10601 !      include 'DIMENSIONS'
10602 !      include 'COMMON.LOCAL'
10603 !      include 'COMMON.IOUNITS'
10604 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
10605 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10606 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
10607       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
10608       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
10609 !el      integer :: it
10610 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
10611 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10612 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
10613 !el local variables
10614
10615       delthec=thetai-thet_pred_mean
10616       delthe0=thetai-theta0i
10617 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
10618       t3 = thetai-thet_pred_mean
10619       t6 = t3**2
10620       t9 = term1
10621       t12 = t3*sigcsq
10622       t14 = t12+t6*sigsqtc
10623       t16 = 1.0d0
10624       t21 = thetai-theta0i
10625       t23 = t21**2
10626       t26 = term2
10627       t27 = t21*t26
10628       t32 = termexp
10629       t40 = t32**2
10630       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
10631        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
10632        *(-t12*t9-ak*sig0inv*t27)
10633       return
10634       end subroutine mixder
10635 #endif
10636 !-----------------------------------------------------------------------------
10637 ! cartder.F
10638 !-----------------------------------------------------------------------------
10639       subroutine cartder
10640 !-----------------------------------------------------------------------------
10641 ! This subroutine calculates the derivatives of the consecutive virtual
10642 ! bond vectors and the SC vectors in the virtual-bond angles theta and
10643 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
10644 ! in the angles alpha and omega, describing the location of a side chain
10645 ! in its local coordinate system.
10646 !
10647 ! The derivatives are stored in the following arrays:
10648 !
10649 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
10650 ! The structure is as follows:
10651 !
10652 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
10653 ! 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)
10654 !         . . . . . . . . . . . .  . . . . . .
10655 ! 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)
10656 !                          .
10657 !                          .
10658 !                          .
10659 ! 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)
10660 !
10661 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
10662 ! The structure is same as above.
10663 !
10664 ! DCDS - the derivatives of the side chain vectors in the local spherical
10665 ! andgles alph and omega:
10666 !
10667 ! 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)
10668 ! 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)
10669 !                          .
10670 !                          .
10671 !                          .
10672 ! 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)
10673 !
10674 ! Version of March '95, based on an early version of November '91.
10675 !
10676 !**********************************************************************
10677 !      implicit real*8 (a-h,o-z)
10678 !      include 'DIMENSIONS'
10679 !      include 'COMMON.VAR'
10680 !      include 'COMMON.CHAIN'
10681 !      include 'COMMON.DERIV'
10682 !      include 'COMMON.GEO'
10683 !      include 'COMMON.LOCAL'
10684 !      include 'COMMON.INTERACT'
10685       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
10686       real(kind=8),dimension(3,3) :: dp,temp
10687 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
10688       real(kind=8),dimension(3) :: xx,xx1
10689 !el local variables
10690       integer :: i,k,l,j,m,ind,ind1,jjj
10691       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
10692                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
10693                  sint2,xp,yp,xxp,yyp,zzp,dj
10694
10695 !      common /przechowalnia/ fromto
10696       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
10697 ! get the position of the jth ijth fragment of the chain coordinate system
10698 ! in the fromto array.
10699 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
10700 !
10701 !      maxdim=(nres-1)*(nres-2)/2
10702 !      allocate(dcdv(6,maxdim),dxds(6,nres))
10703 ! calculate the derivatives of transformation matrix elements in theta
10704 !
10705
10706 !el      call flush(iout) !el
10707       do i=1,nres-2
10708         rdt(1,1,i)=-rt(1,2,i)
10709         rdt(1,2,i)= rt(1,1,i)
10710         rdt(1,3,i)= 0.0d0
10711         rdt(2,1,i)=-rt(2,2,i)
10712         rdt(2,2,i)= rt(2,1,i)
10713         rdt(2,3,i)= 0.0d0
10714         rdt(3,1,i)=-rt(3,2,i)
10715         rdt(3,2,i)= rt(3,1,i)
10716         rdt(3,3,i)= 0.0d0
10717       enddo
10718 !
10719 ! derivatives in phi
10720 !
10721       do i=2,nres-2
10722         drt(1,1,i)= 0.0d0
10723         drt(1,2,i)= 0.0d0
10724         drt(1,3,i)= 0.0d0
10725         drt(2,1,i)= rt(3,1,i)
10726         drt(2,2,i)= rt(3,2,i)
10727         drt(2,3,i)= rt(3,3,i)
10728         drt(3,1,i)=-rt(2,1,i)
10729         drt(3,2,i)=-rt(2,2,i)
10730         drt(3,3,i)=-rt(2,3,i)
10731       enddo
10732 !
10733 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
10734 !
10735       do i=2,nres-2
10736         ind=indmat(i,i+1)
10737         do k=1,3
10738           do l=1,3
10739             temp(k,l)=rt(k,l,i)
10740           enddo
10741         enddo
10742         do k=1,3
10743           do l=1,3
10744             fromto(k,l,ind)=temp(k,l)
10745           enddo
10746         enddo
10747         do j=i+1,nres-2
10748           ind=indmat(i,j+1)
10749           do k=1,3
10750             do l=1,3
10751               dpkl=0.0d0
10752               do m=1,3
10753                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
10754               enddo
10755               dp(k,l)=dpkl
10756               fromto(k,l,ind)=dpkl
10757             enddo
10758           enddo
10759           do k=1,3
10760             do l=1,3
10761               temp(k,l)=dp(k,l)
10762             enddo
10763           enddo
10764         enddo
10765       enddo
10766 !
10767 ! Calculate derivatives.
10768 !
10769       ind1=0
10770       do i=1,nres-2
10771         ind1=ind1+1
10772 !
10773 ! Derivatives of DC(i+1) in theta(i+2)
10774 !
10775         do j=1,3
10776           do k=1,2
10777             dpjk=0.0D0
10778             do l=1,3
10779               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
10780             enddo
10781             dp(j,k)=dpjk
10782             prordt(j,k,i)=dp(j,k)
10783           enddo
10784           dp(j,3)=0.0D0
10785           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
10786         enddo
10787 !
10788 ! Derivatives of SC(i+1) in theta(i+2)
10789 !
10790         xx1(1)=-0.5D0*xloc(2,i+1)
10791         xx1(2)= 0.5D0*xloc(1,i+1)
10792         do j=1,3
10793           xj=0.0D0
10794           do k=1,2
10795             xj=xj+r(j,k,i)*xx1(k)
10796           enddo
10797           xx(j)=xj
10798         enddo
10799         do j=1,3
10800           rj=0.0D0
10801           do k=1,3
10802             rj=rj+prod(j,k,i)*xx(k)
10803           enddo
10804           dxdv(j,ind1)=rj
10805         enddo
10806 !
10807 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
10808 ! than the other off-diagonal derivatives.
10809 !
10810         do j=1,3
10811           dxoiij=0.0D0
10812           do k=1,3
10813             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
10814           enddo
10815           dxdv(j,ind1+1)=dxoiij
10816         enddo
10817 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
10818 !
10819 ! Derivatives of DC(i+1) in phi(i+2)
10820 !
10821         do j=1,3
10822           do k=1,3
10823             dpjk=0.0
10824             do l=2,3
10825               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
10826             enddo
10827             dp(j,k)=dpjk
10828             prodrt(j,k,i)=dp(j,k)
10829           enddo
10830           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
10831         enddo
10832 !
10833 ! Derivatives of SC(i+1) in phi(i+2)
10834 !
10835         xx(1)= 0.0D0
10836         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
10837         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
10838         do j=1,3
10839           rj=0.0D0
10840           do k=2,3
10841             rj=rj+prod(j,k,i)*xx(k)
10842           enddo
10843           dxdv(j+3,ind1)=-rj
10844         enddo
10845 !
10846 ! Derivatives of SC(i+1) in phi(i+3).
10847 !
10848         do j=1,3
10849           dxoiij=0.0D0
10850           do k=1,3
10851             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
10852           enddo
10853           dxdv(j+3,ind1+1)=dxoiij
10854         enddo
10855 !
10856 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
10857 ! theta(nres) and phi(i+3) thru phi(nres).
10858 !
10859         do j=i+1,nres-2
10860           ind1=ind1+1
10861           ind=indmat(i+1,j+1)
10862 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
10863           do k=1,3
10864             do l=1,3
10865               tempkl=0.0D0
10866               do m=1,2
10867                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
10868               enddo
10869               temp(k,l)=tempkl
10870             enddo
10871           enddo
10872 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
10873 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
10874 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
10875 ! Derivatives of virtual-bond vectors in theta
10876           do k=1,3
10877             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
10878           enddo
10879 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
10880 ! Derivatives of SC vectors in theta
10881           do k=1,3
10882             dxoijk=0.0D0
10883             do l=1,3
10884               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10885             enddo
10886             dxdv(k,ind1+1)=dxoijk
10887           enddo
10888 !
10889 !--- Calculate the derivatives in phi
10890 !
10891           do k=1,3
10892             do l=1,3
10893               tempkl=0.0D0
10894               do m=1,3
10895                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
10896               enddo
10897               temp(k,l)=tempkl
10898             enddo
10899           enddo
10900           do k=1,3
10901             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
10902           enddo
10903           do k=1,3
10904             dxoijk=0.0D0
10905             do l=1,3
10906               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
10907             enddo
10908             dxdv(k+3,ind1+1)=dxoijk
10909           enddo
10910         enddo
10911       enddo
10912 !
10913 ! Derivatives in alpha and omega:
10914 !
10915       do i=2,nres-1
10916 !       dsci=dsc(itype(i))
10917         dsci=vbld(i+nres)
10918 #ifdef OSF
10919         alphi=alph(i)
10920         omegi=omeg(i)
10921         if(alphi.ne.alphi) alphi=100.0
10922         if(omegi.ne.omegi) omegi=-100.0
10923 #else
10924         alphi=alph(i)
10925         omegi=omeg(i)
10926 #endif
10927 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
10928         cosalphi=dcos(alphi)
10929         sinalphi=dsin(alphi)
10930         cosomegi=dcos(omegi)
10931         sinomegi=dsin(omegi)
10932         temp(1,1)=-dsci*sinalphi
10933         temp(2,1)= dsci*cosalphi*cosomegi
10934         temp(3,1)=-dsci*cosalphi*sinomegi
10935         temp(1,2)=0.0D0
10936         temp(2,2)=-dsci*sinalphi*sinomegi
10937         temp(3,2)=-dsci*sinalphi*cosomegi
10938         theta2=pi-0.5D0*theta(i+1)
10939         cost2=dcos(theta2)
10940         sint2=dsin(theta2)
10941         jjj=0
10942 !d      print *,((temp(l,k),l=1,3),k=1,2)
10943         do j=1,2
10944           xp=temp(1,j)
10945           yp=temp(2,j)
10946           xxp= xp*cost2+yp*sint2
10947           yyp=-xp*sint2+yp*cost2
10948           zzp=temp(3,j)
10949           xx(1)=xxp
10950           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
10951           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
10952           do k=1,3
10953             dj=0.0D0
10954             do l=1,3
10955               dj=dj+prod(k,l,i-1)*xx(l)
10956             enddo
10957             dxds(jjj+k,i)=dj
10958           enddo
10959           jjj=jjj+3
10960         enddo
10961       enddo
10962       return
10963       end subroutine cartder
10964 !-----------------------------------------------------------------------------
10965 ! checkder_p.F
10966 !-----------------------------------------------------------------------------
10967       subroutine check_cartgrad
10968 ! Check the gradient of Cartesian coordinates in internal coordinates.
10969 !      implicit real*8 (a-h,o-z)
10970 !      include 'DIMENSIONS'
10971 !      include 'COMMON.IOUNITS'
10972 !      include 'COMMON.VAR'
10973 !      include 'COMMON.CHAIN'
10974 !      include 'COMMON.GEO'
10975 !      include 'COMMON.LOCAL'
10976 !      include 'COMMON.DERIV'
10977       real(kind=8),dimension(6,nres) :: temp
10978       real(kind=8),dimension(3) :: xx,gg
10979       integer :: i,k,j,ii
10980       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
10981 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
10982 !
10983 ! Check the gradient of the virtual-bond and SC vectors in the internal
10984 ! coordinates.
10985 !
10986       aincr=1.0d-6
10987       aincr2=5.0d-7
10988       call cartder
10989       write (iout,'(a)') '**************** dx/dalpha'
10990       write (iout,'(a)')
10991       do i=2,nres-1
10992         alphi=alph(i)
10993         alph(i)=alph(i)+aincr
10994         do k=1,3
10995           temp(k,i)=dc(k,nres+i)
10996         enddo
10997         call chainbuild
10998         do k=1,3
10999           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11000           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11001         enddo
11002         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11003         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11004         write (iout,'(a)')
11005         alph(i)=alphi
11006         call chainbuild
11007       enddo
11008       write (iout,'(a)')
11009       write (iout,'(a)') '**************** dx/domega'
11010       write (iout,'(a)')
11011       do i=2,nres-1
11012         omegi=omeg(i)
11013         omeg(i)=omeg(i)+aincr
11014         do k=1,3
11015           temp(k,i)=dc(k,nres+i)
11016         enddo
11017         call chainbuild
11018         do k=1,3
11019           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11020           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11021                 (aincr*dabs(dxds(k+3,i))+aincr))
11022         enddo
11023         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11024             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11025         write (iout,'(a)')
11026         omeg(i)=omegi
11027         call chainbuild
11028       enddo
11029       write (iout,'(a)')
11030       write (iout,'(a)') '**************** dx/dtheta'
11031       write (iout,'(a)')
11032       do i=3,nres
11033         theti=theta(i)
11034         theta(i)=theta(i)+aincr
11035         do j=i-1,nres-1
11036           do k=1,3
11037             temp(k,j)=dc(k,nres+j)
11038           enddo
11039         enddo
11040         call chainbuild
11041         do j=i-1,nres-1
11042           ii = indmat(i-2,j)
11043 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11044           do k=1,3
11045             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11046             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11047                   (aincr*dabs(dxdv(k,ii))+aincr))
11048           enddo
11049           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11050               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11051           write(iout,'(a)')
11052         enddo
11053         write (iout,'(a)')
11054         theta(i)=theti
11055         call chainbuild
11056       enddo
11057       write (iout,'(a)') '***************** dx/dphi'
11058       write (iout,'(a)')
11059       do i=4,nres
11060         phi(i)=phi(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 *,'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+3,ii))/ &
11073                   (aincr*dabs(dxdv(k+3,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+3,ii),k=1,3),(xx(k),k=1,3)
11077           write(iout,'(a)')
11078         enddo
11079         phi(i)=phi(i)-aincr
11080         call chainbuild
11081       enddo
11082       write (iout,'(a)') '****************** ddc/dtheta'
11083       do i=1,nres-2
11084         thet=theta(i+2)
11085         theta(i+2)=thet+aincr
11086         do j=i,nres
11087           do k=1,3
11088             temp(k,j)=dc(k,j)
11089           enddo
11090         enddo
11091         call chainbuild
11092         do j=i+1,nres-1
11093           ii = indmat(i,j)
11094 !         print *,'ii=',ii
11095           do k=1,3
11096             gg(k)=(dc(k,j)-temp(k,j))/aincr
11097             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11098                  (aincr*dabs(dcdv(k,ii))+aincr))
11099           enddo
11100           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11101                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11102           write (iout,'(a)')
11103         enddo
11104         do j=1,nres
11105           do k=1,3
11106             dc(k,j)=temp(k,j)
11107           enddo
11108         enddo
11109         theta(i+2)=thet
11110       enddo
11111       write (iout,'(a)') '******************* ddc/dphi'
11112       do i=1,nres-3
11113         phii=phi(i+3)
11114         phi(i+3)=phii+aincr
11115         do j=1,nres
11116           do k=1,3
11117             temp(k,j)=dc(k,j)
11118           enddo
11119         enddo
11120         call chainbuild
11121         do j=i+2,nres-1
11122           ii = indmat(i+1,j)
11123 !         print *,'ii=',ii
11124           do k=1,3
11125             gg(k)=(dc(k,j)-temp(k,j))/aincr
11126             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11127                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11128           enddo
11129           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11130                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11131           write (iout,'(a)')
11132         enddo
11133         do j=1,nres
11134           do k=1,3
11135             dc(k,j)=temp(k,j)
11136           enddo
11137         enddo
11138         phi(i+3)=phii
11139       enddo
11140       return
11141       end subroutine check_cartgrad
11142 !-----------------------------------------------------------------------------
11143       subroutine check_ecart
11144 ! Check the gradient of the energy in Cartesian coordinates.
11145 !     implicit real*8 (a-h,o-z)
11146 !     include 'DIMENSIONS'
11147 !     include 'COMMON.CHAIN'
11148 !     include 'COMMON.DERIV'
11149 !     include 'COMMON.IOUNITS'
11150 !     include 'COMMON.VAR'
11151 !     include 'COMMON.CONTACTS'
11152       use comm_srutu
11153 !el      integer :: icall
11154 !el      common /srutu/ icall
11155       real(kind=8),dimension(6) :: ggg
11156       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11157       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11158       real(kind=8),dimension(6,nres) :: grad_s
11159       real(kind=8),dimension(0:n_ene) :: energia,energia1
11160       integer :: uiparm(1)
11161       real(kind=8) :: urparm(1)
11162 !EL      external fdum
11163       integer :: nf,i,j,k
11164       real(kind=8) :: aincr,etot,etot1
11165       icg=1
11166       nf=0
11167       nfl=0
11168       call zerograd
11169       aincr=1.0D-5
11170       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11171       nf=0
11172       icall=0
11173       call geom_to_var(nvar,x)
11174       call etotal(energia)
11175       etot=energia(0)
11176 !el      call enerprint(energia)
11177       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11178       icall =1
11179       do i=1,nres
11180         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11181       enddo
11182       do i=1,nres
11183         do j=1,3
11184           grad_s(j,i)=gradc(j,i,icg)
11185           grad_s(j+3,i)=gradx(j,i,icg)
11186         enddo
11187       enddo
11188       call flush(iout)
11189       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11190       do i=1,nres
11191         do j=1,3
11192           xx(j)=c(j,i+nres)
11193           ddc(j)=dc(j,i)
11194           ddx(j)=dc(j,i+nres)
11195         enddo
11196         do j=1,3
11197           dc(j,i)=dc(j,i)+aincr
11198           do k=i+1,nres
11199             c(j,k)=c(j,k)+aincr
11200             c(j,k+nres)=c(j,k+nres)+aincr
11201           enddo
11202           call etotal(energia1)
11203           etot1=energia1(0)
11204           ggg(j)=(etot1-etot)/aincr
11205           dc(j,i)=ddc(j)
11206           do k=i+1,nres
11207             c(j,k)=c(j,k)-aincr
11208             c(j,k+nres)=c(j,k+nres)-aincr
11209           enddo
11210         enddo
11211         do j=1,3
11212           c(j,i+nres)=c(j,i+nres)+aincr
11213           dc(j,i+nres)=dc(j,i+nres)+aincr
11214           call etotal(energia1)
11215           etot1=energia1(0)
11216           ggg(j+3)=(etot1-etot)/aincr
11217           c(j,i+nres)=xx(j)
11218           dc(j,i+nres)=ddx(j)
11219         enddo
11220         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11221          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11222       enddo
11223       return
11224       end subroutine check_ecart
11225 #ifdef CARGRAD
11226 !-----------------------------------------------------------------------------
11227       subroutine check_ecartint
11228 ! Check the gradient of the energy in Cartesian coordinates.
11229       use io_base, only: intout
11230 !      implicit real*8 (a-h,o-z)
11231 !      include 'DIMENSIONS'
11232 !      include 'COMMON.CONTROL'
11233 !      include 'COMMON.CHAIN'
11234 !      include 'COMMON.DERIV'
11235 !      include 'COMMON.IOUNITS'
11236 !      include 'COMMON.VAR'
11237 !      include 'COMMON.CONTACTS'
11238 !      include 'COMMON.MD'
11239 !      include 'COMMON.LOCAL'
11240 !      include 'COMMON.SPLITELE'
11241       use comm_srutu
11242 !el      integer :: icall
11243 !el      common /srutu/ icall
11244       real(kind=8),dimension(6) :: ggg,ggg1
11245       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11246       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11247       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11248       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11249       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11250       real(kind=8),dimension(0:n_ene) :: energia,energia1
11251       integer :: uiparm(1)
11252       real(kind=8) :: urparm(1)
11253 !EL      external fdum
11254       integer :: i,j,k,nf
11255       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11256                    etot21,etot22
11257       r_cut=2.0d0
11258       rlambd=0.3d0
11259       icg=1
11260       nf=0
11261       nfl=0
11262       call intout
11263 !      call intcartderiv
11264 !      call checkintcartgrad
11265       call zerograd
11266       aincr=1.0D-5
11267       write(iout,*) 'Calling CHECK_ECARTINT.'
11268       nf=0
11269       icall=0
11270       write (iout,*) "Before geom_to_var"
11271       call geom_to_var(nvar,x)
11272       write (iout,*) "after geom_to_var"
11273       write (iout,*) "split_ene ",split_ene
11274       call flush(iout)
11275       if (.not.split_ene) then
11276         write(iout,*) 'Calling CHECK_ECARTINT if'
11277         call etotal(energia)
11278 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11279         etot=energia(0)
11280         write (iout,*) "etot",etot
11281         call flush(iout)
11282 !el        call enerprint(energia)
11283 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11284         call flush(iout)
11285         write (iout,*) "enter cartgrad"
11286         call flush(iout)
11287         call cartgrad
11288 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11289         write (iout,*) "exit cartgrad"
11290         call flush(iout)
11291         icall =1
11292         do i=1,nres
11293           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11294         enddo
11295         do j=1,3
11296           grad_s(j,0)=gcart(j,0)
11297         enddo
11298 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11299         do i=1,nres
11300           do j=1,3
11301             grad_s(j,i)=gcart(j,i)
11302             grad_s(j+3,i)=gxcart(j,i)
11303           enddo
11304         enddo
11305       else
11306 write(iout,*) 'Calling CHECK_ECARTIN else.'
11307 !- split gradient check
11308         call zerograd
11309         call etotal_long(energia)
11310 !el        call enerprint(energia)
11311         call flush(iout)
11312         write (iout,*) "enter cartgrad"
11313         call flush(iout)
11314         call cartgrad
11315         write (iout,*) "exit cartgrad"
11316         call flush(iout)
11317         icall =1
11318         write (iout,*) "longrange grad"
11319         do i=1,nres
11320           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11321           (gxcart(j,i),j=1,3)
11322         enddo
11323         do j=1,3
11324           grad_s(j,0)=gcart(j,0)
11325         enddo
11326         do i=1,nres
11327           do j=1,3
11328             grad_s(j,i)=gcart(j,i)
11329             grad_s(j+3,i)=gxcart(j,i)
11330           enddo
11331         enddo
11332         call zerograd
11333         call etotal_short(energia)
11334 !el        call enerprint(energia)
11335         call flush(iout)
11336         write (iout,*) "enter cartgrad"
11337         call flush(iout)
11338         call cartgrad
11339         write (iout,*) "exit cartgrad"
11340         call flush(iout)
11341         icall =1
11342         write (iout,*) "shortrange grad"
11343         do i=1,nres
11344           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11345           (gxcart(j,i),j=1,3)
11346         enddo
11347         do j=1,3
11348           grad_s1(j,0)=gcart(j,0)
11349         enddo
11350         do i=1,nres
11351           do j=1,3
11352             grad_s1(j,i)=gcart(j,i)
11353             grad_s1(j+3,i)=gxcart(j,i)
11354           enddo
11355         enddo
11356       endif
11357       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11358 !      do i=1,nres
11359       do i=nnt,nct
11360         do j=1,3
11361           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11362           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11363           ddc(j)=c(j,i)
11364           ddx(j)=c(j,i+nres)
11365           dcnorm_safe1(j)=dc_norm(j,i-1)
11366           dcnorm_safe2(j)=dc_norm(j,i)
11367           dxnorm_safe(j)=dc_norm(j,i+nres)
11368         enddo
11369         do j=1,3
11370           c(j,i)=ddc(j)+aincr
11371           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11372           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11373           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11374           dc(j,i)=c(j,i+1)-c(j,i)
11375           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11376           call int_from_cart1(.false.)
11377           if (.not.split_ene) then
11378             call etotal(energia1)
11379             etot1=energia1(0)
11380             write (iout,*) "ij",i,j," etot1",etot1
11381           else
11382 !- split gradient
11383             call etotal_long(energia1)
11384             etot11=energia1(0)
11385             call etotal_short(energia1)
11386             etot12=energia1(0)
11387           endif
11388 !- end split gradient
11389 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11390           c(j,i)=ddc(j)-aincr
11391           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11392           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11393           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11394           dc(j,i)=c(j,i+1)-c(j,i)
11395           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11396           call int_from_cart1(.false.)
11397           if (.not.split_ene) then
11398             call etotal(energia1)
11399             etot2=energia1(0)
11400             write (iout,*) "ij",i,j," etot2",etot2
11401             ggg(j)=(etot1-etot2)/(2*aincr)
11402           else
11403 !- split gradient
11404             call etotal_long(energia1)
11405             etot21=energia1(0)
11406             ggg(j)=(etot11-etot21)/(2*aincr)
11407             call etotal_short(energia1)
11408             etot22=energia1(0)
11409             ggg1(j)=(etot12-etot22)/(2*aincr)
11410 !- end split gradient
11411 !            write (iout,*) "etot21",etot21," etot22",etot22
11412           endif
11413 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11414           c(j,i)=ddc(j)
11415           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11416           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11417           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11418           dc(j,i)=c(j,i+1)-c(j,i)
11419           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11420           dc_norm(j,i-1)=dcnorm_safe1(j)
11421           dc_norm(j,i)=dcnorm_safe2(j)
11422           dc_norm(j,i+nres)=dxnorm_safe(j)
11423         enddo
11424         do j=1,3
11425           c(j,i+nres)=ddx(j)+aincr
11426           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11427           call int_from_cart1(.false.)
11428           if (.not.split_ene) then
11429             call etotal(energia1)
11430             etot1=energia1(0)
11431           else
11432 !- split gradient
11433             call etotal_long(energia1)
11434             etot11=energia1(0)
11435             call etotal_short(energia1)
11436             etot12=energia1(0)
11437           endif
11438 !- end split gradient
11439           c(j,i+nres)=ddx(j)-aincr
11440           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11441           call int_from_cart1(.false.)
11442           if (.not.split_ene) then
11443             call etotal(energia1)
11444             etot2=energia1(0)
11445             ggg(j+3)=(etot1-etot2)/(2*aincr)
11446           else
11447 !- split gradient
11448             call etotal_long(energia1)
11449             etot21=energia1(0)
11450             ggg(j+3)=(etot11-etot21)/(2*aincr)
11451             call etotal_short(energia1)
11452             etot22=energia1(0)
11453             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11454 !- end split gradient
11455           endif
11456 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11457           c(j,i+nres)=ddx(j)
11458           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11459           dc_norm(j,i+nres)=dxnorm_safe(j)
11460           call int_from_cart1(.false.)
11461         enddo
11462         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11463          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11464         if (split_ene) then
11465           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11466          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11467          k=1,6)
11468          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11469          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11470          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11471         endif
11472       enddo
11473       return
11474       end subroutine check_ecartint
11475 #else
11476 !-----------------------------------------------------------------------------
11477       subroutine check_ecartint
11478 ! Check the gradient of the energy in Cartesian coordinates.
11479       use io_base, only: intout
11480 !      implicit real*8 (a-h,o-z)
11481 !      include 'DIMENSIONS'
11482 !      include 'COMMON.CONTROL'
11483 !      include 'COMMON.CHAIN'
11484 !      include 'COMMON.DERIV'
11485 !      include 'COMMON.IOUNITS'
11486 !      include 'COMMON.VAR'
11487 !      include 'COMMON.CONTACTS'
11488 !      include 'COMMON.MD'
11489 !      include 'COMMON.LOCAL'
11490 !      include 'COMMON.SPLITELE'
11491       use comm_srutu
11492 !el      integer :: icall
11493 !el      common /srutu/ icall
11494       real(kind=8),dimension(6) :: ggg,ggg1
11495       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11496       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11497       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
11498       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11499       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11500       real(kind=8),dimension(0:n_ene) :: energia,energia1
11501       integer :: uiparm(1)
11502       real(kind=8) :: urparm(1)
11503 !EL      external fdum
11504       integer :: i,j,k,nf
11505       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11506                    etot21,etot22
11507       r_cut=2.0d0
11508       rlambd=0.3d0
11509       icg=1
11510       nf=0
11511       nfl=0
11512       call intout
11513 !      call intcartderiv
11514 !      call checkintcartgrad
11515       call zerograd
11516       aincr=2.0D-5
11517       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
11518       nf=0
11519       icall=0
11520       call geom_to_var(nvar,x)
11521       if (.not.split_ene) then
11522         call etotal(energia)
11523         etot=energia(0)
11524 !el        call enerprint(energia)
11525         call flush(iout)
11526         write (iout,*) "enter cartgrad"
11527         call flush(iout)
11528         call cartgrad
11529         write (iout,*) "exit cartgrad"
11530         call flush(iout)
11531         icall =1
11532         do i=1,nres
11533           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11534         enddo
11535         do j=1,3
11536           grad_s(j,0)=gcart(j,0)
11537         enddo
11538         do i=1,nres
11539           do j=1,3
11540             grad_s(j,i)=gcart(j,i)
11541             grad_s(j+3,i)=gxcart(j,i)
11542           enddo
11543         enddo
11544       else
11545 !- split gradient check
11546         call zerograd
11547         call etotal_long(energia)
11548 !el        call enerprint(energia)
11549         call flush(iout)
11550         write (iout,*) "enter cartgrad"
11551         call flush(iout)
11552         call cartgrad
11553         write (iout,*) "exit cartgrad"
11554         call flush(iout)
11555         icall =1
11556         write (iout,*) "longrange grad"
11557         do i=1,nres
11558           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11559           (gxcart(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         call zerograd
11571         call etotal_short(energia)
11572 !el        call enerprint(energia)
11573         call flush(iout)
11574         write (iout,*) "enter cartgrad"
11575         call flush(iout)
11576         call cartgrad
11577         write (iout,*) "exit cartgrad"
11578         call flush(iout)
11579         icall =1
11580         write (iout,*) "shortrange grad"
11581         do i=1,nres
11582           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11583           (gxcart(j,i),j=1,3)
11584         enddo
11585         do j=1,3
11586           grad_s1(j,0)=gcart(j,0)
11587         enddo
11588         do i=1,nres
11589           do j=1,3
11590             grad_s1(j,i)=gcart(j,i)
11591             grad_s1(j+3,i)=gxcart(j,i)
11592           enddo
11593         enddo
11594       endif
11595       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11596       do i=0,nres
11597         do j=1,3
11598           xx(j)=c(j,i+nres)
11599           ddc(j)=dc(j,i)
11600           ddx(j)=dc(j,i+nres)
11601           do k=1,3
11602             dcnorm_safe(k)=dc_norm(k,i)
11603             dxnorm_safe(k)=dc_norm(k,i+nres)
11604           enddo
11605         enddo
11606         do j=1,3
11607           dc(j,i)=ddc(j)+aincr
11608           call chainbuild_cart
11609 #ifdef MPI
11610 ! Broadcast the order to compute internal coordinates to the slaves.
11611 !          if (nfgtasks.gt.1)
11612 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
11613 #endif
11614 !          call int_from_cart1(.false.)
11615           if (.not.split_ene) then
11616             call etotal(energia1)
11617             etot1=energia1(0)
11618           else
11619 !- split gradient
11620             call etotal_long(energia1)
11621             etot11=energia1(0)
11622             call etotal_short(energia1)
11623             etot12=energia1(0)
11624 !            write (iout,*) "etot11",etot11," etot12",etot12
11625           endif
11626 !- end split gradient
11627 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11628           dc(j,i)=ddc(j)-aincr
11629           call chainbuild_cart
11630 !          call int_from_cart1(.false.)
11631           if (.not.split_ene) then
11632             call etotal(energia1)
11633             etot2=energia1(0)
11634             ggg(j)=(etot1-etot2)/(2*aincr)
11635           else
11636 !- split gradient
11637             call etotal_long(energia1)
11638             etot21=energia1(0)
11639             ggg(j)=(etot11-etot21)/(2*aincr)
11640             call etotal_short(energia1)
11641             etot22=energia1(0)
11642             ggg1(j)=(etot12-etot22)/(2*aincr)
11643 !- end split gradient
11644 !            write (iout,*) "etot21",etot21," etot22",etot22
11645           endif
11646 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11647           dc(j,i)=ddc(j)
11648           call chainbuild_cart
11649         enddo
11650         do j=1,3
11651           dc(j,i+nres)=ddx(j)+aincr
11652           call chainbuild_cart
11653 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
11654 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11655 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11656 !          write (iout,*) "dxnormnorm",dsqrt(
11657 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11658 !          write (iout,*) "dxnormnormsafe",dsqrt(
11659 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11660 !          write (iout,*)
11661           if (.not.split_ene) then
11662             call etotal(energia1)
11663             etot1=energia1(0)
11664           else
11665 !- split gradient
11666             call etotal_long(energia1)
11667             etot11=energia1(0)
11668             call etotal_short(energia1)
11669             etot12=energia1(0)
11670           endif
11671 !- end split gradient
11672 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11673           dc(j,i+nres)=ddx(j)-aincr
11674           call chainbuild_cart
11675 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
11676 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11677 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11678 !          write (iout,*)
11679 !          write (iout,*) "dxnormnorm",dsqrt(
11680 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11681 !          write (iout,*) "dxnormnormsafe",dsqrt(
11682 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11683           if (.not.split_ene) then
11684             call etotal(energia1)
11685             etot2=energia1(0)
11686             ggg(j+3)=(etot1-etot2)/(2*aincr)
11687           else
11688 !- split gradient
11689             call etotal_long(energia1)
11690             etot21=energia1(0)
11691             ggg(j+3)=(etot11-etot21)/(2*aincr)
11692             call etotal_short(energia1)
11693             etot22=energia1(0)
11694             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11695 !- end split gradient
11696           endif
11697 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11698           dc(j,i+nres)=ddx(j)
11699           call chainbuild_cart
11700         enddo
11701         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11702          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11703         if (split_ene) then
11704           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11705          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11706          k=1,6)
11707          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11708          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11709          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11710         endif
11711       enddo
11712       return
11713       end subroutine check_ecartint
11714 #endif
11715 !-----------------------------------------------------------------------------
11716       subroutine check_eint
11717 ! Check the gradient of energy in internal coordinates.
11718 !      implicit real*8 (a-h,o-z)
11719 !      include 'DIMENSIONS'
11720 !      include 'COMMON.CHAIN'
11721 !      include 'COMMON.DERIV'
11722 !      include 'COMMON.IOUNITS'
11723 !      include 'COMMON.VAR'
11724 !      include 'COMMON.GEO'
11725       use comm_srutu
11726 !el      integer :: icall
11727 !el      common /srutu/ icall
11728       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
11729       integer :: uiparm(1)
11730       real(kind=8) :: urparm(1)
11731       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
11732       character(len=6) :: key
11733 !EL      external fdum
11734       integer :: i,ii,nf
11735       real(kind=8) :: xi,aincr,etot,etot1,etot2
11736       call zerograd
11737       aincr=1.0D-7
11738       print '(a)','Calling CHECK_INT.'
11739       nf=0
11740       nfl=0
11741       icg=1
11742       call geom_to_var(nvar,x)
11743       call var_to_geom(nvar,x)
11744       call chainbuild
11745       icall=1
11746       print *,'ICG=',ICG
11747       call etotal(energia)
11748       etot = energia(0)
11749 !el      call enerprint(energia)
11750       print *,'ICG=',ICG
11751 #ifdef MPL
11752       if (MyID.ne.BossID) then
11753         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
11754         nf=x(nvar+1)
11755         nfl=x(nvar+2)
11756         icg=x(nvar+3)
11757       endif
11758 #endif
11759       nf=1
11760       nfl=3
11761 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
11762       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
11763 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
11764       icall=1
11765       do i=1,nvar
11766         xi=x(i)
11767         x(i)=xi-0.5D0*aincr
11768         call var_to_geom(nvar,x)
11769         call chainbuild
11770         call etotal(energia1)
11771         etot1=energia1(0)
11772         x(i)=xi+0.5D0*aincr
11773         call var_to_geom(nvar,x)
11774         call chainbuild
11775         call etotal(energia2)
11776         etot2=energia2(0)
11777         gg(i)=(etot2-etot1)/aincr
11778         write (iout,*) i,etot1,etot2
11779         x(i)=xi
11780       enddo
11781       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
11782           '     RelDiff*100% '
11783       do i=1,nvar
11784         if (i.le.nphi) then
11785           ii=i
11786           key = ' phi'
11787         else if (i.le.nphi+ntheta) then
11788           ii=i-nphi
11789           key=' theta'
11790         else if (i.le.nphi+ntheta+nside) then
11791            ii=i-(nphi+ntheta)
11792            key=' alpha'
11793         else
11794            ii=i-(nphi+ntheta+nside)
11795            key=' omega'
11796         endif
11797         write (iout,'(i3,a,i3,3(1pd16.6))') &
11798        i,key,ii,gg(i),gana(i),&
11799        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
11800       enddo
11801       return
11802       end subroutine check_eint
11803 !-----------------------------------------------------------------------------
11804 ! econstr_local.F
11805 !-----------------------------------------------------------------------------
11806       subroutine Econstr_back
11807 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
11808 !      implicit real*8 (a-h,o-z)
11809 !      include 'DIMENSIONS'
11810 !      include 'COMMON.CONTROL'
11811 !      include 'COMMON.VAR'
11812 !      include 'COMMON.MD'
11813       use MD_data
11814 !#ifndef LANG0
11815 !      include 'COMMON.LANGEVIN'
11816 !#else
11817 !      include 'COMMON.LANGEVIN.lang0'
11818 !#endif
11819 !      include 'COMMON.CHAIN'
11820 !      include 'COMMON.DERIV'
11821 !      include 'COMMON.GEO'
11822 !      include 'COMMON.LOCAL'
11823 !      include 'COMMON.INTERACT'
11824 !      include 'COMMON.IOUNITS'
11825 !      include 'COMMON.NAMES'
11826 !      include 'COMMON.TIME1'
11827       integer :: i,j,ii,k
11828       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
11829
11830       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
11831       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
11832       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
11833
11834       Uconst_back=0.0d0
11835       do i=1,nres
11836         dutheta(i)=0.0d0
11837         dugamma(i)=0.0d0
11838         do j=1,3
11839           duscdiff(j,i)=0.0d0
11840           duscdiffx(j,i)=0.0d0
11841         enddo
11842       enddo
11843       do i=1,nfrag_back
11844         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
11845 !
11846 ! Deviations from theta angles
11847 !
11848         utheta_i=0.0d0
11849         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
11850           dtheta_i=theta(j)-thetaref(j)
11851           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
11852           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
11853         enddo
11854         utheta(i)=utheta_i/(ii-1)
11855 !
11856 ! Deviations from gamma angles
11857 !
11858         ugamma_i=0.0d0
11859         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
11860           dgamma_i=pinorm(phi(j)-phiref(j))
11861 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
11862           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
11863           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
11864 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
11865         enddo
11866         ugamma(i)=ugamma_i/(ii-2)
11867 !
11868 ! Deviations from local SC geometry
11869 !
11870         uscdiff(i)=0.0d0
11871         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
11872           dxx=xxtab(j)-xxref(j)
11873           dyy=yytab(j)-yyref(j)
11874           dzz=zztab(j)-zzref(j)
11875           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
11876           do k=1,3
11877             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
11878              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
11879              (ii-1)
11880             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
11881              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
11882              (ii-1)
11883             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
11884            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
11885             /(ii-1)
11886           enddo
11887 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
11888 !     &      xxref(j),yyref(j),zzref(j)
11889         enddo
11890         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
11891 !        write (iout,*) i," uscdiff",uscdiff(i)
11892 !
11893 ! Put together deviations from local geometry
11894 !
11895         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
11896           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
11897 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
11898 !     &   " uconst_back",uconst_back
11899         utheta(i)=dsqrt(utheta(i))
11900         ugamma(i)=dsqrt(ugamma(i))
11901         uscdiff(i)=dsqrt(uscdiff(i))
11902       enddo
11903       return
11904       end subroutine Econstr_back
11905 !-----------------------------------------------------------------------------
11906 ! energy_p_new-sep_barrier.F
11907 !-----------------------------------------------------------------------------
11908       real(kind=8) function sscale(r)
11909 !      include "COMMON.SPLITELE"
11910       real(kind=8) :: r,gamm
11911       if(r.lt.r_cut-rlamb) then
11912         sscale=1.0d0
11913       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11914         gamm=(r-(r_cut-rlamb))/rlamb
11915         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11916       else
11917         sscale=0d0
11918       endif
11919       return
11920       end function sscale
11921       real(kind=8) function sscale_grad(r)
11922 !      include "COMMON.SPLITELE"
11923       real(kind=8) :: r,gamm
11924       if(r.lt.r_cut-rlamb) then
11925         sscale_grad=0.0d0
11926       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
11927         gamm=(r-(r_cut-rlamb))/rlamb
11928         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
11929       else
11930         sscale_grad=0d0
11931       endif
11932       return
11933       end function sscale_grad
11934
11935 !!!!!!!!!! PBCSCALE
11936       real(kind=8) function sscale_ele(r)
11937 !      include "COMMON.SPLITELE"
11938       real(kind=8) :: r,gamm
11939       if(r.lt.r_cut_ele-rlamb_ele) then
11940         sscale_ele=1.0d0
11941       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11942         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11943         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11944       else
11945         sscale_ele=0d0
11946       endif
11947       return
11948       end function sscale_ele
11949
11950       real(kind=8)  function sscagrad_ele(r)
11951       real(kind=8) :: r,gamm
11952 !      include "COMMON.SPLITELE"
11953       if(r.lt.r_cut_ele-rlamb_ele) then
11954         sscagrad_ele=0.0d0
11955       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
11956         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
11957         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
11958       else
11959         sscagrad_ele=0.0d0
11960       endif
11961       return
11962       end function sscagrad_ele
11963       real(kind=8) function sscalelip(r)
11964       real(kind=8) r,gamm
11965         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
11966       return
11967       end function sscalelip
11968 !C-----------------------------------------------------------------------
11969       real(kind=8) function sscagradlip(r)
11970       real(kind=8) r,gamm
11971         sscagradlip=r*(6.0d0*r-6.0d0)
11972       return
11973       end function sscagradlip
11974
11975 !!!!!!!!!!!!!!!
11976 !-----------------------------------------------------------------------------
11977       subroutine elj_long(evdw)
11978 !
11979 ! This subroutine calculates the interaction energy of nonbonded side chains
11980 ! assuming the LJ potential of interaction.
11981 !
11982 !      implicit real*8 (a-h,o-z)
11983 !      include 'DIMENSIONS'
11984 !      include 'COMMON.GEO'
11985 !      include 'COMMON.VAR'
11986 !      include 'COMMON.LOCAL'
11987 !      include 'COMMON.CHAIN'
11988 !      include 'COMMON.DERIV'
11989 !      include 'COMMON.INTERACT'
11990 !      include 'COMMON.TORSION'
11991 !      include 'COMMON.SBRIDGE'
11992 !      include 'COMMON.NAMES'
11993 !      include 'COMMON.IOUNITS'
11994 !      include 'COMMON.CONTACTS'
11995       real(kind=8),parameter :: accur=1.0d-10
11996       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
11997 !el local variables
11998       integer :: i,iint,j,k,itypi,itypi1,itypj
11999       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12000       real(kind=8) :: e1,e2,evdwij,evdw
12001 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12002       evdw=0.0D0
12003       do i=iatsc_s,iatsc_e
12004         itypi=itype(i)
12005         if (itypi.eq.ntyp1) cycle
12006         itypi1=itype(i+1)
12007         xi=c(1,nres+i)
12008         yi=c(2,nres+i)
12009         zi=c(3,nres+i)
12010 !
12011 ! Calculate SC interaction energy.
12012 !
12013         do iint=1,nint_gr(i)
12014 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12015 !d   &                  'iend=',iend(i,iint)
12016           do j=istart(i,iint),iend(i,iint)
12017             itypj=itype(j)
12018             if (itypj.eq.ntyp1) cycle
12019             xj=c(1,nres+j)-xi
12020             yj=c(2,nres+j)-yi
12021             zj=c(3,nres+j)-zi
12022             rij=xj*xj+yj*yj+zj*zj
12023             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12024             if (sss.lt.1.0d0) then
12025               rrij=1.0D0/rij
12026               eps0ij=eps(itypi,itypj)
12027               fac=rrij**expon2
12028               e1=fac*fac*aa_aq(itypi,itypj)
12029               e2=fac*bb_aq(itypi,itypj)
12030               evdwij=e1+e2
12031               evdw=evdw+(1.0d0-sss)*evdwij
12032 !
12033 ! Calculate the components of the gradient in DC and X
12034 !
12035               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12036               gg(1)=xj*fac
12037               gg(2)=yj*fac
12038               gg(3)=zj*fac
12039               do k=1,3
12040                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12041                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12042                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12043                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12044               enddo
12045             endif
12046           enddo      ! j
12047         enddo        ! iint
12048       enddo          ! i
12049       do i=1,nct
12050         do j=1,3
12051           gvdwc(j,i)=expon*gvdwc(j,i)
12052           gvdwx(j,i)=expon*gvdwx(j,i)
12053         enddo
12054       enddo
12055 !******************************************************************************
12056 !
12057 !                              N O T E !!!
12058 !
12059 ! To save time, the factor of EXPON has been extracted from ALL components
12060 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12061 ! use!
12062 !
12063 !******************************************************************************
12064       return
12065       end subroutine elj_long
12066 !-----------------------------------------------------------------------------
12067       subroutine elj_short(evdw)
12068 !
12069 ! This subroutine calculates the interaction energy of nonbonded side chains
12070 ! assuming the LJ potential of interaction.
12071 !
12072 !      implicit real*8 (a-h,o-z)
12073 !      include 'DIMENSIONS'
12074 !      include 'COMMON.GEO'
12075 !      include 'COMMON.VAR'
12076 !      include 'COMMON.LOCAL'
12077 !      include 'COMMON.CHAIN'
12078 !      include 'COMMON.DERIV'
12079 !      include 'COMMON.INTERACT'
12080 !      include 'COMMON.TORSION'
12081 !      include 'COMMON.SBRIDGE'
12082 !      include 'COMMON.NAMES'
12083 !      include 'COMMON.IOUNITS'
12084 !      include 'COMMON.CONTACTS'
12085       real(kind=8),parameter :: accur=1.0d-10
12086       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12087 !el local variables
12088       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12089       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12090       real(kind=8) :: e1,e2,evdwij,evdw
12091 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12092       evdw=0.0D0
12093       do i=iatsc_s,iatsc_e
12094         itypi=itype(i)
12095         if (itypi.eq.ntyp1) cycle
12096         itypi1=itype(i+1)
12097         xi=c(1,nres+i)
12098         yi=c(2,nres+i)
12099         zi=c(3,nres+i)
12100 ! Change 12/1/95
12101         num_conti=0
12102 !
12103 ! Calculate SC interaction energy.
12104 !
12105         do iint=1,nint_gr(i)
12106 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12107 !d   &                  'iend=',iend(i,iint)
12108           do j=istart(i,iint),iend(i,iint)
12109             itypj=itype(j)
12110             if (itypj.eq.ntyp1) cycle
12111             xj=c(1,nres+j)-xi
12112             yj=c(2,nres+j)-yi
12113             zj=c(3,nres+j)-zi
12114 ! Change 12/1/95 to calculate four-body interactions
12115             rij=xj*xj+yj*yj+zj*zj
12116             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12117             if (sss.gt.0.0d0) then
12118               rrij=1.0D0/rij
12119               eps0ij=eps(itypi,itypj)
12120               fac=rrij**expon2
12121               e1=fac*fac*aa_aq(itypi,itypj)
12122               e2=fac*bb_aq(itypi,itypj)
12123               evdwij=e1+e2
12124               evdw=evdw+sss*evdwij
12125 !
12126 ! Calculate the components of the gradient in DC and X
12127 !
12128               fac=-rrij*(e1+evdwij)*sss
12129               gg(1)=xj*fac
12130               gg(2)=yj*fac
12131               gg(3)=zj*fac
12132               do k=1,3
12133                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12134                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12135                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12136                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12137               enddo
12138             endif
12139           enddo      ! j
12140         enddo        ! iint
12141       enddo          ! i
12142       do i=1,nct
12143         do j=1,3
12144           gvdwc(j,i)=expon*gvdwc(j,i)
12145           gvdwx(j,i)=expon*gvdwx(j,i)
12146         enddo
12147       enddo
12148 !******************************************************************************
12149 !
12150 !                              N O T E !!!
12151 !
12152 ! To save time, the factor of EXPON has been extracted from ALL components
12153 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12154 ! use!
12155 !
12156 !******************************************************************************
12157       return
12158       end subroutine elj_short
12159 !-----------------------------------------------------------------------------
12160       subroutine eljk_long(evdw)
12161 !
12162 ! This subroutine calculates the interaction energy of nonbonded side chains
12163 ! assuming the LJK potential of interaction.
12164 !
12165 !      implicit real*8 (a-h,o-z)
12166 !      include 'DIMENSIONS'
12167 !      include 'COMMON.GEO'
12168 !      include 'COMMON.VAR'
12169 !      include 'COMMON.LOCAL'
12170 !      include 'COMMON.CHAIN'
12171 !      include 'COMMON.DERIV'
12172 !      include 'COMMON.INTERACT'
12173 !      include 'COMMON.IOUNITS'
12174 !      include 'COMMON.NAMES'
12175       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12176       logical :: scheck
12177 !el local variables
12178       integer :: i,iint,j,k,itypi,itypi1,itypj
12179       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12180                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12181 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12182       evdw=0.0D0
12183       do i=iatsc_s,iatsc_e
12184         itypi=itype(i)
12185         if (itypi.eq.ntyp1) cycle
12186         itypi1=itype(i+1)
12187         xi=c(1,nres+i)
12188         yi=c(2,nres+i)
12189         zi=c(3,nres+i)
12190 !
12191 ! Calculate SC interaction energy.
12192 !
12193         do iint=1,nint_gr(i)
12194           do j=istart(i,iint),iend(i,iint)
12195             itypj=itype(j)
12196             if (itypj.eq.ntyp1) cycle
12197             xj=c(1,nres+j)-xi
12198             yj=c(2,nres+j)-yi
12199             zj=c(3,nres+j)-zi
12200             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12201             fac_augm=rrij**expon
12202             e_augm=augm(itypi,itypj)*fac_augm
12203             r_inv_ij=dsqrt(rrij)
12204             rij=1.0D0/r_inv_ij
12205             sss=sscale(rij/sigma(itypi,itypj))
12206             if (sss.lt.1.0d0) then
12207               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12208               fac=r_shift_inv**expon
12209               e1=fac*fac*aa_aq(itypi,itypj)
12210               e2=fac*bb_aq(itypi,itypj)
12211               evdwij=e_augm+e1+e2
12212 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12213 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12214 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12215 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
12216 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12217 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12218 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12219               evdw=evdw+(1.0d0-sss)*evdwij
12220 !
12221 ! Calculate the components of the gradient in DC and X
12222 !
12223               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12224               fac=fac*(1.0d0-sss)
12225               gg(1)=xj*fac
12226               gg(2)=yj*fac
12227               gg(3)=zj*fac
12228               do k=1,3
12229                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12230                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12231                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12232                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12233               enddo
12234             endif
12235           enddo      ! j
12236         enddo        ! iint
12237       enddo          ! i
12238       do i=1,nct
12239         do j=1,3
12240           gvdwc(j,i)=expon*gvdwc(j,i)
12241           gvdwx(j,i)=expon*gvdwx(j,i)
12242         enddo
12243       enddo
12244       return
12245       end subroutine eljk_long
12246 !-----------------------------------------------------------------------------
12247       subroutine eljk_short(evdw)
12248 !
12249 ! This subroutine calculates the interaction energy of nonbonded side chains
12250 ! assuming the LJK potential of interaction.
12251 !
12252 !      implicit real*8 (a-h,o-z)
12253 !      include 'DIMENSIONS'
12254 !      include 'COMMON.GEO'
12255 !      include 'COMMON.VAR'
12256 !      include 'COMMON.LOCAL'
12257 !      include 'COMMON.CHAIN'
12258 !      include 'COMMON.DERIV'
12259 !      include 'COMMON.INTERACT'
12260 !      include 'COMMON.IOUNITS'
12261 !      include 'COMMON.NAMES'
12262       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12263       logical :: scheck
12264 !el local variables
12265       integer :: i,iint,j,k,itypi,itypi1,itypj
12266       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12267                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12268 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12269       evdw=0.0D0
12270       do i=iatsc_s,iatsc_e
12271         itypi=itype(i)
12272         if (itypi.eq.ntyp1) cycle
12273         itypi1=itype(i+1)
12274         xi=c(1,nres+i)
12275         yi=c(2,nres+i)
12276         zi=c(3,nres+i)
12277 !
12278 ! Calculate SC interaction energy.
12279 !
12280         do iint=1,nint_gr(i)
12281           do j=istart(i,iint),iend(i,iint)
12282             itypj=itype(j)
12283             if (itypj.eq.ntyp1) cycle
12284             xj=c(1,nres+j)-xi
12285             yj=c(2,nres+j)-yi
12286             zj=c(3,nres+j)-zi
12287             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12288             fac_augm=rrij**expon
12289             e_augm=augm(itypi,itypj)*fac_augm
12290             r_inv_ij=dsqrt(rrij)
12291             rij=1.0D0/r_inv_ij
12292             sss=sscale(rij/sigma(itypi,itypj))
12293             if (sss.gt.0.0d0) then
12294               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12295               fac=r_shift_inv**expon
12296               e1=fac*fac*aa_aq(itypi,itypj)
12297               e2=fac*bb_aq(itypi,itypj)
12298               evdwij=e_augm+e1+e2
12299 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12300 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12301 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12302 !d   &          restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
12303 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12304 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12305 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12306               evdw=evdw+sss*evdwij
12307 !
12308 ! Calculate the components of the gradient in DC and X
12309 !
12310               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12311               fac=fac*sss
12312               gg(1)=xj*fac
12313               gg(2)=yj*fac
12314               gg(3)=zj*fac
12315               do k=1,3
12316                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12317                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12318                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12319                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12320               enddo
12321             endif
12322           enddo      ! j
12323         enddo        ! iint
12324       enddo          ! i
12325       do i=1,nct
12326         do j=1,3
12327           gvdwc(j,i)=expon*gvdwc(j,i)
12328           gvdwx(j,i)=expon*gvdwx(j,i)
12329         enddo
12330       enddo
12331       return
12332       end subroutine eljk_short
12333 !-----------------------------------------------------------------------------
12334       subroutine ebp_long(evdw)
12335 !
12336 ! This subroutine calculates the interaction energy of nonbonded side chains
12337 ! assuming the Berne-Pechukas potential of interaction.
12338 !
12339       use calc_data
12340 !      implicit real*8 (a-h,o-z)
12341 !      include 'DIMENSIONS'
12342 !      include 'COMMON.GEO'
12343 !      include 'COMMON.VAR'
12344 !      include 'COMMON.LOCAL'
12345 !      include 'COMMON.CHAIN'
12346 !      include 'COMMON.DERIV'
12347 !      include 'COMMON.NAMES'
12348 !      include 'COMMON.INTERACT'
12349 !      include 'COMMON.IOUNITS'
12350 !      include 'COMMON.CALC'
12351       use comm_srutu
12352 !el      integer :: icall
12353 !el      common /srutu/ icall
12354 !     double precision rrsave(maxdim)
12355       logical :: lprn
12356 !el local variables
12357       integer :: iint,itypi,itypi1,itypj
12358       real(kind=8) :: rrij,xi,yi,zi,fac
12359       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12360       evdw=0.0D0
12361 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12362       evdw=0.0D0
12363 !     if (icall.eq.0) then
12364 !       lprn=.true.
12365 !     else
12366         lprn=.false.
12367 !     endif
12368 !el      ind=0
12369       do i=iatsc_s,iatsc_e
12370         itypi=itype(i)
12371         if (itypi.eq.ntyp1) cycle
12372         itypi1=itype(i+1)
12373         xi=c(1,nres+i)
12374         yi=c(2,nres+i)
12375         zi=c(3,nres+i)
12376         dxi=dc_norm(1,nres+i)
12377         dyi=dc_norm(2,nres+i)
12378         dzi=dc_norm(3,nres+i)
12379 !        dsci_inv=dsc_inv(itypi)
12380         dsci_inv=vbld_inv(i+nres)
12381 !
12382 ! Calculate SC interaction energy.
12383 !
12384         do iint=1,nint_gr(i)
12385           do j=istart(i,iint),iend(i,iint)
12386 !el            ind=ind+1
12387             itypj=itype(j)
12388             if (itypj.eq.ntyp1) cycle
12389 !            dscj_inv=dsc_inv(itypj)
12390             dscj_inv=vbld_inv(j+nres)
12391             chi1=chi(itypi,itypj)
12392             chi2=chi(itypj,itypi)
12393             chi12=chi1*chi2
12394             chip1=chip(itypi)
12395             chip2=chip(itypj)
12396             chip12=chip1*chip2
12397             alf1=alp(itypi)
12398             alf2=alp(itypj)
12399             alf12=0.5D0*(alf1+alf2)
12400             xj=c(1,nres+j)-xi
12401             yj=c(2,nres+j)-yi
12402             zj=c(3,nres+j)-zi
12403             dxj=dc_norm(1,nres+j)
12404             dyj=dc_norm(2,nres+j)
12405             dzj=dc_norm(3,nres+j)
12406             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12407             rij=dsqrt(rrij)
12408             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12409
12410             if (sss.lt.1.0d0) then
12411
12412 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12413               call sc_angular
12414 ! Calculate whole angle-dependent part of epsilon and contributions
12415 ! to its derivatives
12416               fac=(rrij*sigsq)**expon2
12417               e1=fac*fac*aa_aq(itypi,itypj)
12418               e2=fac*bb_aq(itypi,itypj)
12419               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12420               eps2der=evdwij*eps3rt
12421               eps3der=evdwij*eps2rt
12422               evdwij=evdwij*eps2rt*eps3rt
12423               evdw=evdw+evdwij*(1.0d0-sss)
12424               if (lprn) then
12425               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12426               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12427 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12428 !d     &          restyp(itypi),i,restyp(itypj),j,
12429 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12430 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12431 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12432 !d     &          evdwij
12433               endif
12434 ! Calculate gradient components.
12435               e1=e1*eps1*eps2rt**2*eps3rt**2
12436               fac=-expon*(e1+evdwij)
12437               sigder=fac/sigsq
12438               fac=rrij*fac
12439 ! Calculate radial part of the gradient
12440               gg(1)=xj*fac
12441               gg(2)=yj*fac
12442               gg(3)=zj*fac
12443 ! Calculate the angular part of the gradient and sum add the contributions
12444 ! to the appropriate components of the Cartesian gradient.
12445               call sc_grad_scale(1.0d0-sss)
12446             endif
12447           enddo      ! j
12448         enddo        ! iint
12449       enddo          ! i
12450 !     stop
12451       return
12452       end subroutine ebp_long
12453 !-----------------------------------------------------------------------------
12454       subroutine ebp_short(evdw)
12455 !
12456 ! This subroutine calculates the interaction energy of nonbonded side chains
12457 ! assuming the Berne-Pechukas potential of interaction.
12458 !
12459       use calc_data
12460 !      implicit real*8 (a-h,o-z)
12461 !      include 'DIMENSIONS'
12462 !      include 'COMMON.GEO'
12463 !      include 'COMMON.VAR'
12464 !      include 'COMMON.LOCAL'
12465 !      include 'COMMON.CHAIN'
12466 !      include 'COMMON.DERIV'
12467 !      include 'COMMON.NAMES'
12468 !      include 'COMMON.INTERACT'
12469 !      include 'COMMON.IOUNITS'
12470 !      include 'COMMON.CALC'
12471       use comm_srutu
12472 !el      integer :: icall
12473 !el      common /srutu/ icall
12474 !     double precision rrsave(maxdim)
12475       logical :: lprn
12476 !el local variables
12477       integer :: iint,itypi,itypi1,itypj
12478       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12479       real(kind=8) :: sss,e1,e2,evdw
12480       evdw=0.0D0
12481 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12482       evdw=0.0D0
12483 !     if (icall.eq.0) then
12484 !       lprn=.true.
12485 !     else
12486         lprn=.false.
12487 !     endif
12488 !el      ind=0
12489       do i=iatsc_s,iatsc_e
12490         itypi=itype(i)
12491         if (itypi.eq.ntyp1) cycle
12492         itypi1=itype(i+1)
12493         xi=c(1,nres+i)
12494         yi=c(2,nres+i)
12495         zi=c(3,nres+i)
12496         dxi=dc_norm(1,nres+i)
12497         dyi=dc_norm(2,nres+i)
12498         dzi=dc_norm(3,nres+i)
12499 !        dsci_inv=dsc_inv(itypi)
12500         dsci_inv=vbld_inv(i+nres)
12501 !
12502 ! Calculate SC interaction energy.
12503 !
12504         do iint=1,nint_gr(i)
12505           do j=istart(i,iint),iend(i,iint)
12506 !el            ind=ind+1
12507             itypj=itype(j)
12508             if (itypj.eq.ntyp1) cycle
12509 !            dscj_inv=dsc_inv(itypj)
12510             dscj_inv=vbld_inv(j+nres)
12511             chi1=chi(itypi,itypj)
12512             chi2=chi(itypj,itypi)
12513             chi12=chi1*chi2
12514             chip1=chip(itypi)
12515             chip2=chip(itypj)
12516             chip12=chip1*chip2
12517             alf1=alp(itypi)
12518             alf2=alp(itypj)
12519             alf12=0.5D0*(alf1+alf2)
12520             xj=c(1,nres+j)-xi
12521             yj=c(2,nres+j)-yi
12522             zj=c(3,nres+j)-zi
12523             dxj=dc_norm(1,nres+j)
12524             dyj=dc_norm(2,nres+j)
12525             dzj=dc_norm(3,nres+j)
12526             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12527             rij=dsqrt(rrij)
12528             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12529
12530             if (sss.gt.0.0d0) then
12531
12532 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12533               call sc_angular
12534 ! Calculate whole angle-dependent part of epsilon and contributions
12535 ! to its derivatives
12536               fac=(rrij*sigsq)**expon2
12537               e1=fac*fac*aa_aq(itypi,itypj)
12538               e2=fac*bb_aq(itypi,itypj)
12539               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12540               eps2der=evdwij*eps3rt
12541               eps3der=evdwij*eps2rt
12542               evdwij=evdwij*eps2rt*eps3rt
12543               evdw=evdw+evdwij*sss
12544               if (lprn) then
12545               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12546               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12547 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12548 !d     &          restyp(itypi),i,restyp(itypj),j,
12549 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12550 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12551 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12552 !d     &          evdwij
12553               endif
12554 ! Calculate gradient components.
12555               e1=e1*eps1*eps2rt**2*eps3rt**2
12556               fac=-expon*(e1+evdwij)
12557               sigder=fac/sigsq
12558               fac=rrij*fac
12559 ! Calculate radial part of the gradient
12560               gg(1)=xj*fac
12561               gg(2)=yj*fac
12562               gg(3)=zj*fac
12563 ! Calculate the angular part of the gradient and sum add the contributions
12564 ! to the appropriate components of the Cartesian gradient.
12565               call sc_grad_scale(sss)
12566             endif
12567           enddo      ! j
12568         enddo        ! iint
12569       enddo          ! i
12570 !     stop
12571       return
12572       end subroutine ebp_short
12573 !-----------------------------------------------------------------------------
12574       subroutine egb_long(evdw)
12575 !
12576 ! This subroutine calculates the interaction energy of nonbonded side chains
12577 ! assuming the Gay-Berne potential of interaction.
12578 !
12579       use calc_data
12580 !      implicit real*8 (a-h,o-z)
12581 !      include 'DIMENSIONS'
12582 !      include 'COMMON.GEO'
12583 !      include 'COMMON.VAR'
12584 !      include 'COMMON.LOCAL'
12585 !      include 'COMMON.CHAIN'
12586 !      include 'COMMON.DERIV'
12587 !      include 'COMMON.NAMES'
12588 !      include 'COMMON.INTERACT'
12589 !      include 'COMMON.IOUNITS'
12590 !      include 'COMMON.CALC'
12591 !      include 'COMMON.CONTROL'
12592       logical :: lprn
12593 !el local variables
12594       integer :: iint,itypi,itypi1,itypj,subchap
12595       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
12596       real(kind=8) :: sss,e1,e2,evdw,sss_grad
12597       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
12598                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
12599                     ssgradlipi,ssgradlipj
12600
12601
12602       evdw=0.0D0
12603 !cccc      energy_dec=.false.
12604 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12605       evdw=0.0D0
12606       lprn=.false.
12607 !     if (icall.eq.0) lprn=.false.
12608 !el      ind=0
12609       do i=iatsc_s,iatsc_e
12610         itypi=itype(i)
12611         if (itypi.eq.ntyp1) cycle
12612         itypi1=itype(i+1)
12613         xi=c(1,nres+i)
12614         yi=c(2,nres+i)
12615         zi=c(3,nres+i)
12616           xi=mod(xi,boxxsize)
12617           if (xi.lt.0) xi=xi+boxxsize
12618           yi=mod(yi,boxysize)
12619           if (yi.lt.0) yi=yi+boxysize
12620           zi=mod(zi,boxzsize)
12621           if (zi.lt.0) zi=zi+boxzsize
12622        if ((zi.gt.bordlipbot)    &
12623         .and.(zi.lt.bordliptop)) then
12624 !C the energy transfer exist
12625         if (zi.lt.buflipbot) then
12626 !C what fraction I am in
12627          fracinbuf=1.0d0-    &
12628              ((zi-bordlipbot)/lipbufthick)
12629 !C lipbufthick is thickenes of lipid buffore
12630          sslipi=sscalelip(fracinbuf)
12631          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
12632         elseif (zi.gt.bufliptop) then
12633          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
12634          sslipi=sscalelip(fracinbuf)
12635          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
12636         else
12637          sslipi=1.0d0
12638          ssgradlipi=0.0
12639         endif
12640        else
12641          sslipi=0.0d0
12642          ssgradlipi=0.0
12643        endif
12644
12645         dxi=dc_norm(1,nres+i)
12646         dyi=dc_norm(2,nres+i)
12647         dzi=dc_norm(3,nres+i)
12648 !        dsci_inv=dsc_inv(itypi)
12649         dsci_inv=vbld_inv(i+nres)
12650 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
12651 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
12652 !
12653 ! Calculate SC interaction energy.
12654 !
12655         do iint=1,nint_gr(i)
12656           do j=istart(i,iint),iend(i,iint)
12657             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
12658               call dyn_ssbond_ene(i,j,evdwij)
12659               evdw=evdw+evdwij
12660               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12661                               'evdw',i,j,evdwij,' ss'
12662 !              if (energy_dec) write (iout,*) &
12663 !                              'evdw',i,j,evdwij,' ss'
12664             ELSE
12665 !el            ind=ind+1
12666             itypj=itype(j)
12667             if (itypj.eq.ntyp1) cycle
12668 !            dscj_inv=dsc_inv(itypj)
12669             dscj_inv=vbld_inv(j+nres)
12670 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
12671 !     &       1.0d0/vbld(j+nres)
12672 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
12673             sig0ij=sigma(itypi,itypj)
12674             chi1=chi(itypi,itypj)
12675             chi2=chi(itypj,itypi)
12676             chi12=chi1*chi2
12677             chip1=chip(itypi)
12678             chip2=chip(itypj)
12679             chip12=chip1*chip2
12680             alf1=alp(itypi)
12681             alf2=alp(itypj)
12682             alf12=0.5D0*(alf1+alf2)
12683             xj=c(1,nres+j)
12684             yj=c(2,nres+j)
12685             zj=c(3,nres+j)
12686 ! Searching for nearest neighbour
12687           xj=mod(xj,boxxsize)
12688           if (xj.lt.0) xj=xj+boxxsize
12689           yj=mod(yj,boxysize)
12690           if (yj.lt.0) yj=yj+boxysize
12691           zj=mod(zj,boxzsize)
12692           if (zj.lt.0) zj=zj+boxzsize
12693        if ((zj.gt.bordlipbot)   &
12694       .and.(zj.lt.bordliptop)) then
12695 !C the energy transfer exist
12696         if (zj.lt.buflipbot) then
12697 !C what fraction I am in
12698          fracinbuf=1.0d0-  &
12699              ((zj-bordlipbot)/lipbufthick)
12700 !C lipbufthick is thickenes of lipid buffore
12701          sslipj=sscalelip(fracinbuf)
12702          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
12703         elseif (zj.gt.bufliptop) then
12704          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
12705          sslipj=sscalelip(fracinbuf)
12706          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
12707         else
12708          sslipj=1.0d0
12709          ssgradlipj=0.0
12710         endif
12711        else
12712          sslipj=0.0d0
12713          ssgradlipj=0.0
12714        endif
12715       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12716        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12717       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12718        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12719
12720           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12721           xj_safe=xj
12722           yj_safe=yj
12723           zj_safe=zj
12724           subchap=0
12725           do xshift=-1,1
12726           do yshift=-1,1
12727           do zshift=-1,1
12728           xj=xj_safe+xshift*boxxsize
12729           yj=yj_safe+yshift*boxysize
12730           zj=zj_safe+zshift*boxzsize
12731           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12732           if(dist_temp.lt.dist_init) then
12733             dist_init=dist_temp
12734             xj_temp=xj
12735             yj_temp=yj
12736             zj_temp=zj
12737             subchap=1
12738           endif
12739           enddo
12740           enddo
12741           enddo
12742           if (subchap.eq.1) then
12743           xj=xj_temp-xi
12744           yj=yj_temp-yi
12745           zj=zj_temp-zi
12746           else
12747           xj=xj_safe-xi
12748           yj=yj_safe-yi
12749           zj=zj_safe-zi
12750           endif
12751
12752             dxj=dc_norm(1,nres+j)
12753             dyj=dc_norm(2,nres+j)
12754             dzj=dc_norm(3,nres+j)
12755             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12756             rij=dsqrt(rrij)
12757             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12758             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
12759             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
12760             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
12761             if (sss_ele_cut.le.0.0) cycle
12762             if (sss.lt.1.0d0) then
12763
12764 ! Calculate angle-dependent terms of energy and contributions to their
12765 ! derivatives.
12766               call sc_angular
12767               sigsq=1.0D0/sigsq
12768               sig=sig0ij*dsqrt(sigsq)
12769               rij_shift=1.0D0/rij-sig+sig0ij
12770 ! for diagnostics; uncomment
12771 !              rij_shift=1.2*sig0ij
12772 ! I hate to put IF's in the loops, but here don't have another choice!!!!
12773               if (rij_shift.le.0.0D0) then
12774                 evdw=1.0D20
12775 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
12776 !d     &          restyp(itypi),i,restyp(itypj),j,
12777 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
12778                 return
12779               endif
12780               sigder=-sig*sigsq
12781 !---------------------------------------------------------------
12782               rij_shift=1.0D0/rij_shift
12783               fac=rij_shift**expon
12784               e1=fac*fac*aa
12785               e2=fac*bb
12786               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12787               eps2der=evdwij*eps3rt
12788               eps3der=evdwij*eps2rt
12789 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
12790 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
12791               evdwij=evdwij*eps2rt*eps3rt
12792               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
12793               if (lprn) then
12794               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12795               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12796               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
12797                 restyp(itypi),i,restyp(itypj),j,&
12798                 epsi,sigm,chi1,chi2,chip1,chip2,&
12799                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
12800                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
12801                 evdwij
12802               endif
12803
12804               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
12805                               'evdw',i,j,evdwij
12806 !              if (energy_dec) write (iout,*) &
12807 !                              'evdw',i,j,evdwij,"egb_long"
12808
12809 ! Calculate gradient components.
12810               e1=e1*eps1*eps2rt**2*eps3rt**2
12811               fac=-expon*(e1+evdwij)*rij_shift
12812               sigder=fac*sigder
12813               fac=rij*fac
12814               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
12815             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
12816             /sigmaii(itypi,itypj))
12817 !              fac=0.0d0
12818 ! Calculate the radial part of the gradient
12819               gg(1)=xj*fac
12820               gg(2)=yj*fac
12821               gg(3)=zj*fac
12822 ! Calculate angular part of the gradient.
12823               call sc_grad_scale(1.0d0-sss)
12824             ENDIF    !mask_dyn_ss
12825             endif
12826           enddo      ! j
12827         enddo        ! iint
12828       enddo          ! i
12829 !      write (iout,*) "Number of loop steps in EGB:",ind
12830 !ccc      energy_dec=.false.
12831       return
12832       end subroutine egb_long
12833 !-----------------------------------------------------------------------------
12834       subroutine egb_short(evdw)
12835 !
12836 ! This subroutine calculates the interaction energy of nonbonded side chains
12837 ! assuming the Gay-Berne potential of interaction.
12838 !
12839       use calc_data
12840 !      implicit real*8 (a-h,o-z)
12841 !      include 'DIMENSIONS'
12842 !      include 'COMMON.GEO'
12843 !      include 'COMMON.VAR'
12844 !      include 'COMMON.LOCAL'
12845 !      include 'COMMON.CHAIN'
12846 !      include 'COMMON.DERIV'
12847 !      include 'COMMON.NAMES'
12848 !      include 'COMMON.INTERACT'
12849 !      include 'COMMON.IOUNITS'
12850 !      include 'COMMON.CALC'
12851 !      include 'COMMON.CONTROL'
12852       logical :: lprn
12853 !el local variables
12854       integer :: iint,itypi,itypi1,itypj,subchap
12855       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
12856       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
12857       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
12858                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
12859                     ssgradlipi,ssgradlipj
12860       evdw=0.0D0
12861 !cccc      energy_dec=.false.
12862 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12863       evdw=0.0D0
12864       lprn=.false.
12865 !     if (icall.eq.0) lprn=.false.
12866 !el      ind=0
12867       do i=iatsc_s,iatsc_e
12868         itypi=itype(i)
12869         if (itypi.eq.ntyp1) cycle
12870         itypi1=itype(i+1)
12871         xi=c(1,nres+i)
12872         yi=c(2,nres+i)
12873         zi=c(3,nres+i)
12874           xi=mod(xi,boxxsize)
12875           if (xi.lt.0) xi=xi+boxxsize
12876           yi=mod(yi,boxysize)
12877           if (yi.lt.0) yi=yi+boxysize
12878           zi=mod(zi,boxzsize)
12879           if (zi.lt.0) zi=zi+boxzsize
12880        if ((zi.gt.bordlipbot)    &
12881         .and.(zi.lt.bordliptop)) then
12882 !C the energy transfer exist
12883         if (zi.lt.buflipbot) then
12884 !C what fraction I am in
12885          fracinbuf=1.0d0-    &
12886              ((zi-bordlipbot)/lipbufthick)
12887 !C lipbufthick is thickenes of lipid buffore
12888          sslipi=sscalelip(fracinbuf)
12889          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
12890         elseif (zi.gt.bufliptop) then
12891          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
12892          sslipi=sscalelip(fracinbuf)
12893          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
12894         else
12895          sslipi=1.0d0
12896          ssgradlipi=0.0
12897         endif
12898        else
12899          sslipi=0.0d0
12900          ssgradlipi=0.0
12901        endif
12902
12903         dxi=dc_norm(1,nres+i)
12904         dyi=dc_norm(2,nres+i)
12905         dzi=dc_norm(3,nres+i)
12906 !        dsci_inv=dsc_inv(itypi)
12907         dsci_inv=vbld_inv(i+nres)
12908
12909         dxi=dc_norm(1,nres+i)
12910         dyi=dc_norm(2,nres+i)
12911         dzi=dc_norm(3,nres+i)
12912 !        dsci_inv=dsc_inv(itypi)
12913         dsci_inv=vbld_inv(i+nres)
12914 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
12915 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
12916 !
12917 ! Calculate SC interaction energy.
12918 !
12919         do iint=1,nint_gr(i)
12920           do j=istart(i,iint),iend(i,iint)
12921             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
12922               call dyn_ssbond_ene(i,j,evdwij)
12923               evdw=evdw+evdwij
12924               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12925                               'evdw',i,j,evdwij,' ss'
12926 !              if (energy_dec) write (iout,*) &
12927 !                              'evdw',i,j,evdwij,' ss'
12928             ELSE
12929 !el            ind=ind+1
12930             itypj=itype(j)
12931             if (itypj.eq.ntyp1) cycle
12932 !            dscj_inv=dsc_inv(itypj)
12933             dscj_inv=vbld_inv(j+nres)
12934 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
12935 !     &       1.0d0/vbld(j+nres)
12936 !            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
12937             sig0ij=sigma(itypi,itypj)
12938             chi1=chi(itypi,itypj)
12939             chi2=chi(itypj,itypi)
12940             chi12=chi1*chi2
12941             chip1=chip(itypi)
12942             chip2=chip(itypj)
12943             chip12=chip1*chip2
12944             alf1=alp(itypi)
12945             alf2=alp(itypj)
12946             alf12=0.5D0*(alf1+alf2)
12947 !            xj=c(1,nres+j)-xi
12948 !            yj=c(2,nres+j)-yi
12949 !            zj=c(3,nres+j)-zi
12950             xj=c(1,nres+j)
12951             yj=c(2,nres+j)
12952             zj=c(3,nres+j)
12953 ! Searching for nearest neighbour
12954           xj=mod(xj,boxxsize)
12955           if (xj.lt.0) xj=xj+boxxsize
12956           yj=mod(yj,boxysize)
12957           if (yj.lt.0) yj=yj+boxysize
12958           zj=mod(zj,boxzsize)
12959           if (zj.lt.0) zj=zj+boxzsize
12960        if ((zj.gt.bordlipbot)   &
12961       .and.(zj.lt.bordliptop)) then
12962 !C the energy transfer exist
12963         if (zj.lt.buflipbot) then
12964 !C what fraction I am in
12965          fracinbuf=1.0d0-  &
12966              ((zj-bordlipbot)/lipbufthick)
12967 !C lipbufthick is thickenes of lipid buffore
12968          sslipj=sscalelip(fracinbuf)
12969          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
12970         elseif (zj.gt.bufliptop) then
12971          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
12972          sslipj=sscalelip(fracinbuf)
12973          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
12974         else
12975          sslipj=1.0d0
12976          ssgradlipj=0.0
12977         endif
12978        else
12979          sslipj=0.0d0
12980          ssgradlipj=0.0
12981        endif
12982       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12983        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12984       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
12985        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
12986
12987           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
12988           xj_safe=xj
12989           yj_safe=yj
12990           zj_safe=zj
12991           subchap=0
12992
12993           do xshift=-1,1
12994           do yshift=-1,1
12995           do zshift=-1,1
12996           xj=xj_safe+xshift*boxxsize
12997           yj=yj_safe+yshift*boxysize
12998           zj=zj_safe+zshift*boxzsize
12999           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13000           if(dist_temp.lt.dist_init) then
13001             dist_init=dist_temp
13002             xj_temp=xj
13003             yj_temp=yj
13004             zj_temp=zj
13005             subchap=1
13006           endif
13007           enddo
13008           enddo
13009           enddo
13010           if (subchap.eq.1) then
13011           xj=xj_temp-xi
13012           yj=yj_temp-yi
13013           zj=zj_temp-zi
13014           else
13015           xj=xj_safe-xi
13016           yj=yj_safe-yi
13017           zj=zj_safe-zi
13018           endif
13019
13020             dxj=dc_norm(1,nres+j)
13021             dyj=dc_norm(2,nres+j)
13022             dzj=dc_norm(3,nres+j)
13023             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13024             rij=dsqrt(rrij)
13025             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13026             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13027             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13028             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13029             if (sss_ele_cut.le.0.0) cycle
13030
13031             if (sss.gt.0.0d0) then
13032
13033 ! Calculate angle-dependent terms of energy and contributions to their
13034 ! derivatives.
13035               call sc_angular
13036               sigsq=1.0D0/sigsq
13037               sig=sig0ij*dsqrt(sigsq)
13038               rij_shift=1.0D0/rij-sig+sig0ij
13039 ! for diagnostics; uncomment
13040 !              rij_shift=1.2*sig0ij
13041 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13042               if (rij_shift.le.0.0D0) then
13043                 evdw=1.0D20
13044 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13045 !d     &          restyp(itypi),i,restyp(itypj),j,
13046 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13047                 return
13048               endif
13049               sigder=-sig*sigsq
13050 !---------------------------------------------------------------
13051               rij_shift=1.0D0/rij_shift
13052               fac=rij_shift**expon
13053               e1=fac*fac*aa
13054               e2=fac*bb
13055               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13056               eps2der=evdwij*eps3rt
13057               eps3der=evdwij*eps2rt
13058 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13059 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13060               evdwij=evdwij*eps2rt*eps3rt
13061               evdw=evdw+evdwij*sss*sss_ele_cut
13062               if (lprn) then
13063               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13064               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13065               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13066                 restyp(itypi),i,restyp(itypj),j,&
13067                 epsi,sigm,chi1,chi2,chip1,chip2,&
13068                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13069                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13070                 evdwij
13071               endif
13072
13073               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13074                               'evdw',i,j,evdwij
13075 !              if (energy_dec) write (iout,*) &
13076 !                              'evdw',i,j,evdwij,"egb_short"
13077
13078 ! Calculate gradient components.
13079               e1=e1*eps1*eps2rt**2*eps3rt**2
13080               fac=-expon*(e1+evdwij)*rij_shift
13081               sigder=fac*sigder
13082               fac=rij*fac
13083               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13084             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13085             /sigmaii(itypi,itypj))
13086
13087 !              fac=0.0d0
13088 ! Calculate the radial part of the gradient
13089               gg(1)=xj*fac
13090               gg(2)=yj*fac
13091               gg(3)=zj*fac
13092 ! Calculate angular part of the gradient.
13093               call sc_grad_scale(sss)
13094             endif
13095           ENDIF !mask_dyn_ss
13096           enddo      ! j
13097         enddo        ! iint
13098       enddo          ! i
13099 !      write (iout,*) "Number of loop steps in EGB:",ind
13100 !ccc      energy_dec=.false.
13101       return
13102       end subroutine egb_short
13103 !-----------------------------------------------------------------------------
13104       subroutine egbv_long(evdw)
13105 !
13106 ! This subroutine calculates the interaction energy of nonbonded side chains
13107 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13108 !
13109       use calc_data
13110 !      implicit real*8 (a-h,o-z)
13111 !      include 'DIMENSIONS'
13112 !      include 'COMMON.GEO'
13113 !      include 'COMMON.VAR'
13114 !      include 'COMMON.LOCAL'
13115 !      include 'COMMON.CHAIN'
13116 !      include 'COMMON.DERIV'
13117 !      include 'COMMON.NAMES'
13118 !      include 'COMMON.INTERACT'
13119 !      include 'COMMON.IOUNITS'
13120 !      include 'COMMON.CALC'
13121       use comm_srutu
13122 !el      integer :: icall
13123 !el      common /srutu/ icall
13124       logical :: lprn
13125 !el local variables
13126       integer :: iint,itypi,itypi1,itypj
13127       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13128       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13129       evdw=0.0D0
13130 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13131       evdw=0.0D0
13132       lprn=.false.
13133 !     if (icall.eq.0) lprn=.true.
13134 !el      ind=0
13135       do i=iatsc_s,iatsc_e
13136         itypi=itype(i)
13137         if (itypi.eq.ntyp1) cycle
13138         itypi1=itype(i+1)
13139         xi=c(1,nres+i)
13140         yi=c(2,nres+i)
13141         zi=c(3,nres+i)
13142         dxi=dc_norm(1,nres+i)
13143         dyi=dc_norm(2,nres+i)
13144         dzi=dc_norm(3,nres+i)
13145 !        dsci_inv=dsc_inv(itypi)
13146         dsci_inv=vbld_inv(i+nres)
13147 !
13148 ! Calculate SC interaction energy.
13149 !
13150         do iint=1,nint_gr(i)
13151           do j=istart(i,iint),iend(i,iint)
13152 !el            ind=ind+1
13153             itypj=itype(j)
13154             if (itypj.eq.ntyp1) cycle
13155 !            dscj_inv=dsc_inv(itypj)
13156             dscj_inv=vbld_inv(j+nres)
13157             sig0ij=sigma(itypi,itypj)
13158             r0ij=r0(itypi,itypj)
13159             chi1=chi(itypi,itypj)
13160             chi2=chi(itypj,itypi)
13161             chi12=chi1*chi2
13162             chip1=chip(itypi)
13163             chip2=chip(itypj)
13164             chip12=chip1*chip2
13165             alf1=alp(itypi)
13166             alf2=alp(itypj)
13167             alf12=0.5D0*(alf1+alf2)
13168             xj=c(1,nres+j)-xi
13169             yj=c(2,nres+j)-yi
13170             zj=c(3,nres+j)-zi
13171             dxj=dc_norm(1,nres+j)
13172             dyj=dc_norm(2,nres+j)
13173             dzj=dc_norm(3,nres+j)
13174             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13175             rij=dsqrt(rrij)
13176
13177             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13178
13179             if (sss.lt.1.0d0) then
13180
13181 ! Calculate angle-dependent terms of energy and contributions to their
13182 ! derivatives.
13183               call sc_angular
13184               sigsq=1.0D0/sigsq
13185               sig=sig0ij*dsqrt(sigsq)
13186               rij_shift=1.0D0/rij-sig+r0ij
13187 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13188               if (rij_shift.le.0.0D0) then
13189                 evdw=1.0D20
13190                 return
13191               endif
13192               sigder=-sig*sigsq
13193 !---------------------------------------------------------------
13194               rij_shift=1.0D0/rij_shift
13195               fac=rij_shift**expon
13196               e1=fac*fac*aa_aq(itypi,itypj)
13197               e2=fac*bb_aq(itypi,itypj)
13198               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13199               eps2der=evdwij*eps3rt
13200               eps3der=evdwij*eps2rt
13201               fac_augm=rrij**expon
13202               e_augm=augm(itypi,itypj)*fac_augm
13203               evdwij=evdwij*eps2rt*eps3rt
13204               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13205               if (lprn) then
13206               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13207               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13208               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13209                 restyp(itypi),i,restyp(itypj),j,&
13210                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13211                 chi1,chi2,chip1,chip2,&
13212                 eps1,eps2rt**2,eps3rt**2,&
13213                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13214                 evdwij+e_augm
13215               endif
13216 ! Calculate gradient components.
13217               e1=e1*eps1*eps2rt**2*eps3rt**2
13218               fac=-expon*(e1+evdwij)*rij_shift
13219               sigder=fac*sigder
13220               fac=rij*fac-2*expon*rrij*e_augm
13221 ! Calculate the radial part of the gradient
13222               gg(1)=xj*fac
13223               gg(2)=yj*fac
13224               gg(3)=zj*fac
13225 ! Calculate angular part of the gradient.
13226               call sc_grad_scale(1.0d0-sss)
13227             endif
13228           enddo      ! j
13229         enddo        ! iint
13230       enddo          ! i
13231       end subroutine egbv_long
13232 !-----------------------------------------------------------------------------
13233       subroutine egbv_short(evdw)
13234 !
13235 ! This subroutine calculates the interaction energy of nonbonded side chains
13236 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13237 !
13238       use calc_data
13239 !      implicit real*8 (a-h,o-z)
13240 !      include 'DIMENSIONS'
13241 !      include 'COMMON.GEO'
13242 !      include 'COMMON.VAR'
13243 !      include 'COMMON.LOCAL'
13244 !      include 'COMMON.CHAIN'
13245 !      include 'COMMON.DERIV'
13246 !      include 'COMMON.NAMES'
13247 !      include 'COMMON.INTERACT'
13248 !      include 'COMMON.IOUNITS'
13249 !      include 'COMMON.CALC'
13250       use comm_srutu
13251 !el      integer :: icall
13252 !el      common /srutu/ icall
13253       logical :: lprn
13254 !el local variables
13255       integer :: iint,itypi,itypi1,itypj
13256       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13257       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13258       evdw=0.0D0
13259 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13260       evdw=0.0D0
13261       lprn=.false.
13262 !     if (icall.eq.0) lprn=.true.
13263 !el      ind=0
13264       do i=iatsc_s,iatsc_e
13265         itypi=itype(i)
13266         if (itypi.eq.ntyp1) cycle
13267         itypi1=itype(i+1)
13268         xi=c(1,nres+i)
13269         yi=c(2,nres+i)
13270         zi=c(3,nres+i)
13271         dxi=dc_norm(1,nres+i)
13272         dyi=dc_norm(2,nres+i)
13273         dzi=dc_norm(3,nres+i)
13274 !        dsci_inv=dsc_inv(itypi)
13275         dsci_inv=vbld_inv(i+nres)
13276 !
13277 ! Calculate SC interaction energy.
13278 !
13279         do iint=1,nint_gr(i)
13280           do j=istart(i,iint),iend(i,iint)
13281 !el            ind=ind+1
13282             itypj=itype(j)
13283             if (itypj.eq.ntyp1) cycle
13284 !            dscj_inv=dsc_inv(itypj)
13285             dscj_inv=vbld_inv(j+nres)
13286             sig0ij=sigma(itypi,itypj)
13287             r0ij=r0(itypi,itypj)
13288             chi1=chi(itypi,itypj)
13289             chi2=chi(itypj,itypi)
13290             chi12=chi1*chi2
13291             chip1=chip(itypi)
13292             chip2=chip(itypj)
13293             chip12=chip1*chip2
13294             alf1=alp(itypi)
13295             alf2=alp(itypj)
13296             alf12=0.5D0*(alf1+alf2)
13297             xj=c(1,nres+j)-xi
13298             yj=c(2,nres+j)-yi
13299             zj=c(3,nres+j)-zi
13300             dxj=dc_norm(1,nres+j)
13301             dyj=dc_norm(2,nres+j)
13302             dzj=dc_norm(3,nres+j)
13303             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13304             rij=dsqrt(rrij)
13305
13306             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13307
13308             if (sss.gt.0.0d0) then
13309
13310 ! Calculate angle-dependent terms of energy and contributions to their
13311 ! derivatives.
13312               call sc_angular
13313               sigsq=1.0D0/sigsq
13314               sig=sig0ij*dsqrt(sigsq)
13315               rij_shift=1.0D0/rij-sig+r0ij
13316 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13317               if (rij_shift.le.0.0D0) then
13318                 evdw=1.0D20
13319                 return
13320               endif
13321               sigder=-sig*sigsq
13322 !---------------------------------------------------------------
13323               rij_shift=1.0D0/rij_shift
13324               fac=rij_shift**expon
13325               e1=fac*fac*aa_aq(itypi,itypj)
13326               e2=fac*bb_aq(itypi,itypj)
13327               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13328               eps2der=evdwij*eps3rt
13329               eps3der=evdwij*eps2rt
13330               fac_augm=rrij**expon
13331               e_augm=augm(itypi,itypj)*fac_augm
13332               evdwij=evdwij*eps2rt*eps3rt
13333               evdw=evdw+(evdwij+e_augm)*sss
13334               if (lprn) then
13335               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13336               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13337               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13338                 restyp(itypi),i,restyp(itypj),j,&
13339                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13340                 chi1,chi2,chip1,chip2,&
13341                 eps1,eps2rt**2,eps3rt**2,&
13342                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13343                 evdwij+e_augm
13344               endif
13345 ! Calculate gradient components.
13346               e1=e1*eps1*eps2rt**2*eps3rt**2
13347               fac=-expon*(e1+evdwij)*rij_shift
13348               sigder=fac*sigder
13349               fac=rij*fac-2*expon*rrij*e_augm
13350 ! Calculate the radial part of the gradient
13351               gg(1)=xj*fac
13352               gg(2)=yj*fac
13353               gg(3)=zj*fac
13354 ! Calculate angular part of the gradient.
13355               call sc_grad_scale(sss)
13356             endif
13357           enddo      ! j
13358         enddo        ! iint
13359       enddo          ! i
13360       end subroutine egbv_short
13361 !-----------------------------------------------------------------------------
13362       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13363 !
13364 ! This subroutine calculates the average interaction energy and its gradient
13365 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13366 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13367 ! The potential depends both on the distance of peptide-group centers and on
13368 ! the orientation of the CA-CA virtual bonds.
13369 !
13370 !      implicit real*8 (a-h,o-z)
13371
13372       use comm_locel
13373 #ifdef MPI
13374       include 'mpif.h'
13375 #endif
13376 !      include 'DIMENSIONS'
13377 !      include 'COMMON.CONTROL'
13378 !      include 'COMMON.SETUP'
13379 !      include 'COMMON.IOUNITS'
13380 !      include 'COMMON.GEO'
13381 !      include 'COMMON.VAR'
13382 !      include 'COMMON.LOCAL'
13383 !      include 'COMMON.CHAIN'
13384 !      include 'COMMON.DERIV'
13385 !      include 'COMMON.INTERACT'
13386 !      include 'COMMON.CONTACTS'
13387 !      include 'COMMON.TORSION'
13388 !      include 'COMMON.VECTORS'
13389 !      include 'COMMON.FFIELD'
13390 !      include 'COMMON.TIME1'
13391       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13392       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13393       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13394 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13395       real(kind=8),dimension(4) :: muij
13396 !el      integer :: num_conti,j1,j2
13397 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13398 !el                   dz_normi,xmedi,ymedi,zmedi
13399 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13400 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13401 !el          num_conti,j1,j2
13402 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13403 #ifdef MOMENT
13404       real(kind=8) :: scal_el=1.0d0
13405 #else
13406       real(kind=8) :: scal_el=0.5d0
13407 #endif
13408 ! 12/13/98
13409 ! 13-go grudnia roku pamietnego...
13410       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13411                                              0.0d0,1.0d0,0.0d0,&
13412                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13413 !el local variables
13414       integer :: i,j,k
13415       real(kind=8) :: fac
13416       real(kind=8) :: dxj,dyj,dzj
13417       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13418
13419 !      allocate(num_cont_hb(nres)) !(maxres)
13420 !d      write(iout,*) 'In EELEC'
13421 !d      do i=1,nloctyp
13422 !d        write(iout,*) 'Type',i
13423 !d        write(iout,*) 'B1',B1(:,i)
13424 !d        write(iout,*) 'B2',B2(:,i)
13425 !d        write(iout,*) 'CC',CC(:,:,i)
13426 !d        write(iout,*) 'DD',DD(:,:,i)
13427 !d        write(iout,*) 'EE',EE(:,:,i)
13428 !d      enddo
13429 !d      call check_vecgrad
13430 !d      stop
13431       if (icheckgrad.eq.1) then
13432         do i=1,nres-1
13433           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13434           do k=1,3
13435             dc_norm(k,i)=dc(k,i)*fac
13436           enddo
13437 !          write (iout,*) 'i',i,' fac',fac
13438         enddo
13439       endif
13440       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13441           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13442           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13443 !        call vec_and_deriv
13444 #ifdef TIMING
13445         time01=MPI_Wtime()
13446 #endif
13447 !        print *, "before set matrices"
13448         call set_matrices
13449 !        print *,"after set martices"
13450 #ifdef TIMING
13451         time_mat=time_mat+MPI_Wtime()-time01
13452 #endif
13453       endif
13454 !d      do i=1,nres-1
13455 !d        write (iout,*) 'i=',i
13456 !d        do k=1,3
13457 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
13458 !d        enddo
13459 !d        do k=1,3
13460 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
13461 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
13462 !d        enddo
13463 !d      enddo
13464       t_eelecij=0.0d0
13465       ees=0.0D0
13466       evdw1=0.0D0
13467       eel_loc=0.0d0
13468       eello_turn3=0.0d0
13469       eello_turn4=0.0d0
13470 !el      ind=0
13471       do i=1,nres
13472         num_cont_hb(i)=0
13473       enddo
13474 !d      print '(a)','Enter EELEC'
13475 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
13476 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13477 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13478       do i=1,nres
13479         gel_loc_loc(i)=0.0d0
13480         gcorr_loc(i)=0.0d0
13481       enddo
13482 !
13483 !
13484 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
13485 !
13486 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
13487 !
13488       do i=iturn3_start,iturn3_end
13489         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 &
13490         .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
13491         dxi=dc(1,i)
13492         dyi=dc(2,i)
13493         dzi=dc(3,i)
13494         dx_normi=dc_norm(1,i)
13495         dy_normi=dc_norm(2,i)
13496         dz_normi=dc_norm(3,i)
13497         xmedi=c(1,i)+0.5d0*dxi
13498         ymedi=c(2,i)+0.5d0*dyi
13499         zmedi=c(3,i)+0.5d0*dzi
13500           xmedi=dmod(xmedi,boxxsize)
13501           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13502           ymedi=dmod(ymedi,boxysize)
13503           if (ymedi.lt.0) ymedi=ymedi+boxysize
13504           zmedi=dmod(zmedi,boxzsize)
13505           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13506         num_conti=0
13507         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
13508         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
13509         num_cont_hb(i)=num_conti
13510       enddo
13511       do i=iturn4_start,iturn4_end
13512         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 &
13513           .or. itype(i+3).eq.ntyp1 &
13514           .or. itype(i+4).eq.ntyp1) cycle
13515         dxi=dc(1,i)
13516         dyi=dc(2,i)
13517         dzi=dc(3,i)
13518         dx_normi=dc_norm(1,i)
13519         dy_normi=dc_norm(2,i)
13520         dz_normi=dc_norm(3,i)
13521         xmedi=c(1,i)+0.5d0*dxi
13522         ymedi=c(2,i)+0.5d0*dyi
13523         zmedi=c(3,i)+0.5d0*dzi
13524           xmedi=dmod(xmedi,boxxsize)
13525           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13526           ymedi=dmod(ymedi,boxysize)
13527           if (ymedi.lt.0) ymedi=ymedi+boxysize
13528           zmedi=dmod(zmedi,boxzsize)
13529           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13530         num_conti=num_cont_hb(i)
13531         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
13532         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) &
13533           call eturn4(i,eello_turn4)
13534         num_cont_hb(i)=num_conti
13535       enddo   ! i
13536 !
13537 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
13538 !
13539       do i=iatel_s,iatel_e
13540         if (itype(i).eq.ntyp1 .or. itype(i+1).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 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
13557         num_conti=num_cont_hb(i)
13558         do j=ielstart(i),ielend(i)
13559           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
13560           call eelecij_scale(i,j,ees,evdw1,eel_loc)
13561         enddo ! j
13562         num_cont_hb(i)=num_conti
13563       enddo   ! i
13564 !      write (iout,*) "Number of loop steps in EELEC:",ind
13565 !d      do i=1,nres
13566 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
13567 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
13568 !d      enddo
13569 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
13570 !cc      eel_loc=eel_loc+eello_turn3
13571 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
13572       return
13573       end subroutine eelec_scale
13574 !-----------------------------------------------------------------------------
13575       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
13576 !      implicit real*8 (a-h,o-z)
13577
13578       use comm_locel
13579 !      include 'DIMENSIONS'
13580 #ifdef MPI
13581       include "mpif.h"
13582 #endif
13583 !      include 'COMMON.CONTROL'
13584 !      include 'COMMON.IOUNITS'
13585 !      include 'COMMON.GEO'
13586 !      include 'COMMON.VAR'
13587 !      include 'COMMON.LOCAL'
13588 !      include 'COMMON.CHAIN'
13589 !      include 'COMMON.DERIV'
13590 !      include 'COMMON.INTERACT'
13591 !      include 'COMMON.CONTACTS'
13592 !      include 'COMMON.TORSION'
13593 !      include 'COMMON.VECTORS'
13594 !      include 'COMMON.FFIELD'
13595 !      include 'COMMON.TIME1'
13596       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
13597       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
13598       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13599 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13600       real(kind=8),dimension(4) :: muij
13601       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13602                     dist_temp, dist_init,sss_grad
13603       integer xshift,yshift,zshift
13604
13605 !el      integer :: num_conti,j1,j2
13606 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13607 !el                   dz_normi,xmedi,ymedi,zmedi
13608 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13609 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13610 !el          num_conti,j1,j2
13611 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13612 #ifdef MOMENT
13613       real(kind=8) :: scal_el=1.0d0
13614 #else
13615       real(kind=8) :: scal_el=0.5d0
13616 #endif
13617 ! 12/13/98
13618 ! 13-go grudnia roku pamietnego...
13619       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13620                                              0.0d0,1.0d0,0.0d0,&
13621                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13622 !el local variables
13623       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
13624       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
13625       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
13626       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
13627       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
13628       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
13629       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
13630                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
13631                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
13632                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
13633                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
13634                   ecosam,ecosbm,ecosgm,ghalf,time00
13635 !      integer :: maxconts
13636 !      maxconts = nres/4
13637 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13638 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13639 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13640 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13641 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13642 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13643 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13644 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13645 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
13646 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
13647 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
13648 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
13649 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
13650
13651 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
13652 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
13653
13654 #ifdef MPI
13655           time00=MPI_Wtime()
13656 #endif
13657 !d      write (iout,*) "eelecij",i,j
13658 !el          ind=ind+1
13659           iteli=itel(i)
13660           itelj=itel(j)
13661           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
13662           aaa=app(iteli,itelj)
13663           bbb=bpp(iteli,itelj)
13664           ael6i=ael6(iteli,itelj)
13665           ael3i=ael3(iteli,itelj)
13666           dxj=dc(1,j)
13667           dyj=dc(2,j)
13668           dzj=dc(3,j)
13669           dx_normj=dc_norm(1,j)
13670           dy_normj=dc_norm(2,j)
13671           dz_normj=dc_norm(3,j)
13672 !          xj=c(1,j)+0.5D0*dxj-xmedi
13673 !          yj=c(2,j)+0.5D0*dyj-ymedi
13674 !          zj=c(3,j)+0.5D0*dzj-zmedi
13675           xj=c(1,j)+0.5D0*dxj
13676           yj=c(2,j)+0.5D0*dyj
13677           zj=c(3,j)+0.5D0*dzj
13678           xj=mod(xj,boxxsize)
13679           if (xj.lt.0) xj=xj+boxxsize
13680           yj=mod(yj,boxysize)
13681           if (yj.lt.0) yj=yj+boxysize
13682           zj=mod(zj,boxzsize)
13683           if (zj.lt.0) zj=zj+boxzsize
13684       isubchap=0
13685       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13686       xj_safe=xj
13687       yj_safe=yj
13688       zj_safe=zj
13689       do xshift=-1,1
13690       do yshift=-1,1
13691       do zshift=-1,1
13692           xj=xj_safe+xshift*boxxsize
13693           yj=yj_safe+yshift*boxysize
13694           zj=zj_safe+zshift*boxzsize
13695           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
13696           if(dist_temp.lt.dist_init) then
13697             dist_init=dist_temp
13698             xj_temp=xj
13699             yj_temp=yj
13700             zj_temp=zj
13701             isubchap=1
13702           endif
13703        enddo
13704        enddo
13705        enddo
13706        if (isubchap.eq.1) then
13707 !C          print *,i,j
13708           xj=xj_temp-xmedi
13709           yj=yj_temp-ymedi
13710           zj=zj_temp-zmedi
13711        else
13712           xj=xj_safe-xmedi
13713           yj=yj_safe-ymedi
13714           zj=zj_safe-zmedi
13715        endif
13716
13717           rij=xj*xj+yj*yj+zj*zj
13718           rrmij=1.0D0/rij
13719           rij=dsqrt(rij)
13720           rmij=1.0D0/rij
13721 ! For extracting the short-range part of Evdwpp
13722           sss=sscale(rij/rpp(iteli,itelj))
13723             sss_ele_cut=sscale_ele(rij)
13724             sss_ele_grad=sscagrad_ele(rij)
13725             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
13726 !             sss_ele_cut=1.0d0
13727 !             sss_ele_grad=0.0d0
13728             if (sss_ele_cut.le.0.0) go to 128
13729
13730           r3ij=rrmij*rmij
13731           r6ij=r3ij*r3ij
13732           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
13733           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
13734           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
13735           fac=cosa-3.0D0*cosb*cosg
13736           ev1=aaa*r6ij*r6ij
13737 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
13738           if (j.eq.i+2) ev1=scal_el*ev1
13739           ev2=bbb*r6ij
13740           fac3=ael6i*r6ij
13741           fac4=ael3i*r3ij
13742           evdwij=ev1+ev2
13743           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
13744           el2=fac4*fac
13745           eesij=el1+el2
13746 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
13747           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
13748           ees=ees+eesij*sss_ele_cut
13749           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
13750 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
13751 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
13752 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
13753 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
13754
13755           if (energy_dec) then
13756               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
13757               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
13758           endif
13759
13760 !
13761 ! Calculate contributions to the Cartesian gradient.
13762 !
13763 #ifdef SPLITELE
13764           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
13765           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
13766           fac1=fac
13767           erij(1)=xj*rmij
13768           erij(2)=yj*rmij
13769           erij(3)=zj*rmij
13770 !
13771 ! Radial derivatives. First process both termini of the fragment (i,j)
13772 !
13773           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
13774           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
13775           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
13776 !          do k=1,3
13777 !            ghalf=0.5D0*ggg(k)
13778 !            gelc(k,i)=gelc(k,i)+ghalf
13779 !            gelc(k,j)=gelc(k,j)+ghalf
13780 !          enddo
13781 ! 9/28/08 AL Gradient compotents will be summed only at the end
13782           do k=1,3
13783             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
13784             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
13785           enddo
13786 !
13787 ! Loop over residues i+1 thru j-1.
13788 !
13789 !grad          do k=i+1,j-1
13790 !grad            do l=1,3
13791 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
13792 !grad            enddo
13793 !grad          enddo
13794           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
13795           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
13796           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
13797           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
13798           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
13799           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
13800 !          do k=1,3
13801 !            ghalf=0.5D0*ggg(k)
13802 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
13803 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
13804 !          enddo
13805 ! 9/28/08 AL Gradient compotents will be summed only at the end
13806           do k=1,3
13807             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
13808             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
13809           enddo
13810 !
13811 ! Loop over residues i+1 thru j-1.
13812 !
13813 !grad          do k=i+1,j-1
13814 !grad            do l=1,3
13815 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
13816 !grad            enddo
13817 !grad          enddo
13818 #else
13819           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
13820           facel=(el1+eesij)*sss_ele_cut
13821           fac1=fac
13822           fac=-3*rrmij*(facvdw+facvdw+facel)
13823           erij(1)=xj*rmij
13824           erij(2)=yj*rmij
13825           erij(3)=zj*rmij
13826 !
13827 ! Radial derivatives. First process both termini of the fragment (i,j)
13828 !
13829           ggg(1)=fac*xj
13830           ggg(2)=fac*yj
13831           ggg(3)=fac*zj
13832 !          do k=1,3
13833 !            ghalf=0.5D0*ggg(k)
13834 !            gelc(k,i)=gelc(k,i)+ghalf
13835 !            gelc(k,j)=gelc(k,j)+ghalf
13836 !          enddo
13837 ! 9/28/08 AL Gradient compotents will be summed only at the end
13838           do k=1,3
13839             gelc_long(k,j)=gelc(k,j)+ggg(k)
13840             gelc_long(k,i)=gelc(k,i)-ggg(k)
13841           enddo
13842 !
13843 ! Loop over residues i+1 thru j-1.
13844 !
13845 !grad          do k=i+1,j-1
13846 !grad            do l=1,3
13847 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
13848 !grad            enddo
13849 !grad          enddo
13850 ! 9/28/08 AL Gradient compotents will be summed only at the end
13851           ggg(1)=facvdw*xj
13852           ggg(2)=facvdw*yj
13853           ggg(3)=facvdw*zj
13854           do k=1,3
13855             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
13856             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
13857           enddo
13858 #endif
13859 !
13860 ! Angular part
13861 !
13862           ecosa=2.0D0*fac3*fac1+fac4
13863           fac4=-3.0D0*fac4
13864           fac3=-6.0D0*fac3
13865           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
13866           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
13867           do k=1,3
13868             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
13869             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
13870           enddo
13871 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
13872 !d   &          (dcosg(k),k=1,3)
13873           do k=1,3
13874             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
13875           enddo
13876 !          do k=1,3
13877 !            ghalf=0.5D0*ggg(k)
13878 !            gelc(k,i)=gelc(k,i)+ghalf
13879 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
13880 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
13881 !            gelc(k,j)=gelc(k,j)+ghalf
13882 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
13883 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
13884 !          enddo
13885 !grad          do k=i+1,j-1
13886 !grad            do l=1,3
13887 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
13888 !grad            enddo
13889 !grad          enddo
13890           do k=1,3
13891             gelc(k,i)=gelc(k,i) &
13892                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
13893                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
13894                      *sss_ele_cut
13895             gelc(k,j)=gelc(k,j) &
13896                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
13897                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
13898                      *sss_ele_cut
13899             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
13900             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
13901           enddo
13902           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13903               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
13904               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
13905 !
13906 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
13907 !   energy of a peptide unit is assumed in the form of a second-order
13908 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
13909 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
13910 !   are computed for EVERY pair of non-contiguous peptide groups.
13911 !
13912           if (j.lt.nres-1) then
13913             j1=j+1
13914             j2=j-1
13915           else
13916             j1=j-1
13917             j2=j-2
13918           endif
13919           kkk=0
13920           do k=1,2
13921             do l=1,2
13922               kkk=kkk+1
13923               muij(kkk)=mu(k,i)*mu(l,j)
13924             enddo
13925           enddo
13926 !d         write (iout,*) 'EELEC: i',i,' j',j
13927 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
13928 !d          write(iout,*) 'muij',muij
13929           ury=scalar(uy(1,i),erij)
13930           urz=scalar(uz(1,i),erij)
13931           vry=scalar(uy(1,j),erij)
13932           vrz=scalar(uz(1,j),erij)
13933           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
13934           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
13935           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
13936           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
13937           fac=dsqrt(-ael6i)*r3ij
13938           a22=a22*fac
13939           a23=a23*fac
13940           a32=a32*fac
13941           a33=a33*fac
13942 !d          write (iout,'(4i5,4f10.5)')
13943 !d     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
13944 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
13945 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
13946 !d     &      uy(:,j),uz(:,j)
13947 !d          write (iout,'(4f10.5)')
13948 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
13949 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
13950 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
13951 !d           write (iout,'(9f10.5/)')
13952 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
13953 ! Derivatives of the elements of A in virtual-bond vectors
13954           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
13955           do k=1,3
13956             uryg(k,1)=scalar(erder(1,k),uy(1,i))
13957             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
13958             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
13959             urzg(k,1)=scalar(erder(1,k),uz(1,i))
13960             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
13961             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
13962             vryg(k,1)=scalar(erder(1,k),uy(1,j))
13963             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
13964             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
13965             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
13966             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
13967             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
13968           enddo
13969 ! Compute radial contributions to the gradient
13970           facr=-3.0d0*rrmij
13971           a22der=a22*facr
13972           a23der=a23*facr
13973           a32der=a32*facr
13974           a33der=a33*facr
13975           agg(1,1)=a22der*xj
13976           agg(2,1)=a22der*yj
13977           agg(3,1)=a22der*zj
13978           agg(1,2)=a23der*xj
13979           agg(2,2)=a23der*yj
13980           agg(3,2)=a23der*zj
13981           agg(1,3)=a32der*xj
13982           agg(2,3)=a32der*yj
13983           agg(3,3)=a32der*zj
13984           agg(1,4)=a33der*xj
13985           agg(2,4)=a33der*yj
13986           agg(3,4)=a33der*zj
13987 ! Add the contributions coming from er
13988           fac3=-3.0d0*fac
13989           do k=1,3
13990             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
13991             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
13992             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
13993             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
13994           enddo
13995           do k=1,3
13996 ! Derivatives in DC(i)
13997 !grad            ghalf1=0.5d0*agg(k,1)
13998 !grad            ghalf2=0.5d0*agg(k,2)
13999 !grad            ghalf3=0.5d0*agg(k,3)
14000 !grad            ghalf4=0.5d0*agg(k,4)
14001             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14002             -3.0d0*uryg(k,2)*vry)!+ghalf1
14003             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14004             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14005             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14006             -3.0d0*urzg(k,2)*vry)!+ghalf3
14007             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14008             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14009 ! Derivatives in DC(i+1)
14010             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14011             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14012             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14013             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14014             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14015             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14016             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14017             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14018 ! Derivatives in DC(j)
14019             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14020             -3.0d0*vryg(k,2)*ury)!+ghalf1
14021             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14022             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14023             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14024             -3.0d0*vryg(k,2)*urz)!+ghalf3
14025             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14026             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14027 ! Derivatives in DC(j+1) or DC(nres-1)
14028             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14029             -3.0d0*vryg(k,3)*ury)
14030             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14031             -3.0d0*vrzg(k,3)*ury)
14032             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14033             -3.0d0*vryg(k,3)*urz)
14034             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14035             -3.0d0*vrzg(k,3)*urz)
14036 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14037 !grad              do l=1,4
14038 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14039 !grad              enddo
14040 !grad            endif
14041           enddo
14042           acipa(1,1)=a22
14043           acipa(1,2)=a23
14044           acipa(2,1)=a32
14045           acipa(2,2)=a33
14046           a22=-a22
14047           a23=-a23
14048           do l=1,2
14049             do k=1,3
14050               agg(k,l)=-agg(k,l)
14051               aggi(k,l)=-aggi(k,l)
14052               aggi1(k,l)=-aggi1(k,l)
14053               aggj(k,l)=-aggj(k,l)
14054               aggj1(k,l)=-aggj1(k,l)
14055             enddo
14056           enddo
14057           if (j.lt.nres-1) then
14058             a22=-a22
14059             a32=-a32
14060             do l=1,3,2
14061               do k=1,3
14062                 agg(k,l)=-agg(k,l)
14063                 aggi(k,l)=-aggi(k,l)
14064                 aggi1(k,l)=-aggi1(k,l)
14065                 aggj(k,l)=-aggj(k,l)
14066                 aggj1(k,l)=-aggj1(k,l)
14067               enddo
14068             enddo
14069           else
14070             a22=-a22
14071             a23=-a23
14072             a32=-a32
14073             a33=-a33
14074             do l=1,4
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           endif
14084           ENDIF ! WCORR
14085           IF (wel_loc.gt.0.0d0) THEN
14086 ! Contribution to the local-electrostatic energy coming from the i-j pair
14087           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14088            +a33*muij(4)
14089 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14090
14091           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14092                   'eelloc',i,j,eel_loc_ij
14093 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14094
14095           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14096 ! Partial derivatives in virtual-bond dihedral angles gamma
14097           if (i.gt.1) &
14098           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14099                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14100                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14101                  *sss_ele_cut
14102           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14103                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14104                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14105                  *sss_ele_cut
14106            xtemp(1)=xj
14107            xtemp(2)=yj
14108            xtemp(3)=zj
14109
14110 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14111           do l=1,3
14112             ggg(l)=(agg(l,1)*muij(1)+ &
14113                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14114             *sss_ele_cut &
14115              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14116
14117             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14118             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14119 !grad            ghalf=0.5d0*ggg(l)
14120 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14121 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14122           enddo
14123 !grad          do k=i+1,j2
14124 !grad            do l=1,3
14125 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14126 !grad            enddo
14127 !grad          enddo
14128 ! Remaining derivatives of eello
14129           do l=1,3
14130             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14131                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14132             *sss_ele_cut
14133
14134             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14135                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14136             *sss_ele_cut
14137
14138             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14139                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14140             *sss_ele_cut
14141
14142             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14143                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14144             *sss_ele_cut
14145
14146           enddo
14147           ENDIF
14148 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14149 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14150           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14151              .and. num_conti.le.maxconts) then
14152 !            write (iout,*) i,j," entered corr"
14153 !
14154 ! Calculate the contact function. The ith column of the array JCONT will
14155 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14156 ! greater than I). The arrays FACONT and GACONT will contain the values of
14157 ! the contact function and its derivative.
14158 !           r0ij=1.02D0*rpp(iteli,itelj)
14159 !           r0ij=1.11D0*rpp(iteli,itelj)
14160             r0ij=2.20D0*rpp(iteli,itelj)
14161 !           r0ij=1.55D0*rpp(iteli,itelj)
14162             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14163 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14164             if (fcont.gt.0.0D0) then
14165               num_conti=num_conti+1
14166               if (num_conti.gt.maxconts) then
14167 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14168                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14169                                ' will skip next contacts for this conf.',num_conti
14170               else
14171                 jcont_hb(num_conti,i)=j
14172 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14173 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14174                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14175                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14176 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14177 !  terms.
14178                 d_cont(num_conti,i)=rij
14179 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14180 !     --- Electrostatic-interaction matrix ---
14181                 a_chuj(1,1,num_conti,i)=a22
14182                 a_chuj(1,2,num_conti,i)=a23
14183                 a_chuj(2,1,num_conti,i)=a32
14184                 a_chuj(2,2,num_conti,i)=a33
14185 !     --- Gradient of rij
14186                 do kkk=1,3
14187                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14188                 enddo
14189                 kkll=0
14190                 do k=1,2
14191                   do l=1,2
14192                     kkll=kkll+1
14193                     do m=1,3
14194                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14195                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14196                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14197                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14198                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14199                     enddo
14200                   enddo
14201                 enddo
14202                 ENDIF
14203                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14204 ! Calculate contact energies
14205                 cosa4=4.0D0*cosa
14206                 wij=cosa-3.0D0*cosb*cosg
14207                 cosbg1=cosb+cosg
14208                 cosbg2=cosb-cosg
14209 !               fac3=dsqrt(-ael6i)/r0ij**3
14210                 fac3=dsqrt(-ael6i)*r3ij
14211 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14212                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14213                 if (ees0tmp.gt.0) then
14214                   ees0pij=dsqrt(ees0tmp)
14215                 else
14216                   ees0pij=0
14217                 endif
14218 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14219                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14220                 if (ees0tmp.gt.0) then
14221                   ees0mij=dsqrt(ees0tmp)
14222                 else
14223                   ees0mij=0
14224                 endif
14225 !               ees0mij=0.0D0
14226                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14227                      *sss_ele_cut
14228
14229                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14230                      *sss_ele_cut
14231
14232 ! Diagnostics. Comment out or remove after debugging!
14233 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14234 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14235 !               ees0m(num_conti,i)=0.0D0
14236 ! End diagnostics.
14237 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14238 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14239 ! Angular derivatives of the contact function
14240                 ees0pij1=fac3/ees0pij
14241                 ees0mij1=fac3/ees0mij
14242                 fac3p=-3.0D0*fac3*rrmij
14243                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14244                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14245 !               ees0mij1=0.0D0
14246                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14247                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14248                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14249                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14250                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14251                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14252                 ecosap=ecosa1+ecosa2
14253                 ecosbp=ecosb1+ecosb2
14254                 ecosgp=ecosg1+ecosg2
14255                 ecosam=ecosa1-ecosa2
14256                 ecosbm=ecosb1-ecosb2
14257                 ecosgm=ecosg1-ecosg2
14258 ! Diagnostics
14259 !               ecosap=ecosa1
14260 !               ecosbp=ecosb1
14261 !               ecosgp=ecosg1
14262 !               ecosam=0.0D0
14263 !               ecosbm=0.0D0
14264 !               ecosgm=0.0D0
14265 ! End diagnostics
14266                 facont_hb(num_conti,i)=fcont
14267                 fprimcont=fprimcont/rij
14268 !d              facont_hb(num_conti,i)=1.0D0
14269 ! Following line is for diagnostics.
14270 !d              fprimcont=0.0D0
14271                 do k=1,3
14272                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14273                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14274                 enddo
14275                 do k=1,3
14276                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14277                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14278                 enddo
14279 !                gggp(1)=gggp(1)+ees0pijp*xj
14280 !                gggp(2)=gggp(2)+ees0pijp*yj
14281 !                gggp(3)=gggp(3)+ees0pijp*zj
14282 !                gggm(1)=gggm(1)+ees0mijp*xj
14283 !                gggm(2)=gggm(2)+ees0mijp*yj
14284 !                gggm(3)=gggm(3)+ees0mijp*zj
14285                 gggp(1)=gggp(1)+ees0pijp*xj &
14286                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14287                 gggp(2)=gggp(2)+ees0pijp*yj &
14288                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14289                 gggp(3)=gggp(3)+ees0pijp*zj &
14290                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14291
14292                 gggm(1)=gggm(1)+ees0mijp*xj &
14293                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14294
14295                 gggm(2)=gggm(2)+ees0mijp*yj &
14296                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14297
14298                 gggm(3)=gggm(3)+ees0mijp*zj &
14299                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14300
14301 ! Derivatives due to the contact function
14302                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14303                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14304                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14305                 do k=1,3
14306 !
14307 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14308 !          following the change of gradient-summation algorithm.
14309 !
14310 !grad                  ghalfp=0.5D0*gggp(k)
14311 !grad                  ghalfm=0.5D0*gggm(k)
14312 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14313 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14314 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14315 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14316 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14317 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14318 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14319 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14320 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14321 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14322 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14323 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14324 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14325 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14326                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14327                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14328                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14329                      *sss_ele_cut
14330
14331                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14332                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14333                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14334                      *sss_ele_cut
14335
14336                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14337                      *sss_ele_cut
14338
14339                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14340                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14341                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14342                      *sss_ele_cut
14343
14344                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14345                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14346                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14347                      *sss_ele_cut
14348
14349                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14350                      *sss_ele_cut
14351
14352                 enddo
14353               ENDIF ! wcorr
14354               endif  ! num_conti.le.maxconts
14355             endif  ! fcont.gt.0
14356           endif    ! j.gt.i+1
14357           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14358             do k=1,4
14359               do l=1,3
14360                 ghalf=0.5d0*agg(l,k)
14361                 aggi(l,k)=aggi(l,k)+ghalf
14362                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14363                 aggj(l,k)=aggj(l,k)+ghalf
14364               enddo
14365             enddo
14366             if (j.eq.nres-1 .and. i.lt.j-2) then
14367               do k=1,4
14368                 do l=1,3
14369                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14370                 enddo
14371               enddo
14372             endif
14373           endif
14374  128      continue
14375 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14376       return
14377       end subroutine eelecij_scale
14378 !-----------------------------------------------------------------------------
14379       subroutine evdwpp_short(evdw1)
14380 !
14381 ! Compute Evdwpp
14382 !
14383 !      implicit real*8 (a-h,o-z)
14384 !      include 'DIMENSIONS'
14385 !      include 'COMMON.CONTROL'
14386 !      include 'COMMON.IOUNITS'
14387 !      include 'COMMON.GEO'
14388 !      include 'COMMON.VAR'
14389 !      include 'COMMON.LOCAL'
14390 !      include 'COMMON.CHAIN'
14391 !      include 'COMMON.DERIV'
14392 !      include 'COMMON.INTERACT'
14393 !      include 'COMMON.CONTACTS'
14394 !      include 'COMMON.TORSION'
14395 !      include 'COMMON.VECTORS'
14396 !      include 'COMMON.FFIELD'
14397       real(kind=8),dimension(3) :: ggg
14398 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14399 #ifdef MOMENT
14400       real(kind=8) :: scal_el=1.0d0
14401 #else
14402       real(kind=8) :: scal_el=0.5d0
14403 #endif
14404 !el local variables
14405       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14406       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14407       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14408                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14409                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14410       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14411                     dist_temp, dist_init,sss_grad
14412       integer xshift,yshift,zshift
14413
14414
14415       evdw1=0.0D0
14416 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14417 !     & " iatel_e_vdw",iatel_e_vdw
14418       call flush(iout)
14419       do i=iatel_s_vdw,iatel_e_vdw
14420         if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle
14421         dxi=dc(1,i)
14422         dyi=dc(2,i)
14423         dzi=dc(3,i)
14424         dx_normi=dc_norm(1,i)
14425         dy_normi=dc_norm(2,i)
14426         dz_normi=dc_norm(3,i)
14427         xmedi=c(1,i)+0.5d0*dxi
14428         ymedi=c(2,i)+0.5d0*dyi
14429         zmedi=c(3,i)+0.5d0*dzi
14430           xmedi=dmod(xmedi,boxxsize)
14431           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14432           ymedi=dmod(ymedi,boxysize)
14433           if (ymedi.lt.0) ymedi=ymedi+boxysize
14434           zmedi=dmod(zmedi,boxzsize)
14435           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14436         num_conti=0
14437 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14438 !     &   ' ielend',ielend_vdw(i)
14439         call flush(iout)
14440         do j=ielstart_vdw(i),ielend_vdw(i)
14441           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
14442 !el          ind=ind+1
14443           iteli=itel(i)
14444           itelj=itel(j)
14445           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14446           aaa=app(iteli,itelj)
14447           bbb=bpp(iteli,itelj)
14448           dxj=dc(1,j)
14449           dyj=dc(2,j)
14450           dzj=dc(3,j)
14451           dx_normj=dc_norm(1,j)
14452           dy_normj=dc_norm(2,j)
14453           dz_normj=dc_norm(3,j)
14454 !          xj=c(1,j)+0.5D0*dxj-xmedi
14455 !          yj=c(2,j)+0.5D0*dyj-ymedi
14456 !          zj=c(3,j)+0.5D0*dzj-zmedi
14457           xj=c(1,j)+0.5D0*dxj
14458           yj=c(2,j)+0.5D0*dyj
14459           zj=c(3,j)+0.5D0*dzj
14460           xj=mod(xj,boxxsize)
14461           if (xj.lt.0) xj=xj+boxxsize
14462           yj=mod(yj,boxysize)
14463           if (yj.lt.0) yj=yj+boxysize
14464           zj=mod(zj,boxzsize)
14465           if (zj.lt.0) zj=zj+boxzsize
14466       isubchap=0
14467       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14468       xj_safe=xj
14469       yj_safe=yj
14470       zj_safe=zj
14471       do xshift=-1,1
14472       do yshift=-1,1
14473       do zshift=-1,1
14474           xj=xj_safe+xshift*boxxsize
14475           yj=yj_safe+yshift*boxysize
14476           zj=zj_safe+zshift*boxzsize
14477           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14478           if(dist_temp.lt.dist_init) then
14479             dist_init=dist_temp
14480             xj_temp=xj
14481             yj_temp=yj
14482             zj_temp=zj
14483             isubchap=1
14484           endif
14485        enddo
14486        enddo
14487        enddo
14488        if (isubchap.eq.1) then
14489 !C          print *,i,j
14490           xj=xj_temp-xmedi
14491           yj=yj_temp-ymedi
14492           zj=zj_temp-zmedi
14493        else
14494           xj=xj_safe-xmedi
14495           yj=yj_safe-ymedi
14496           zj=zj_safe-zmedi
14497        endif
14498
14499           rij=xj*xj+yj*yj+zj*zj
14500           rrmij=1.0D0/rij
14501           rij=dsqrt(rij)
14502           sss=sscale(rij/rpp(iteli,itelj))
14503             sss_ele_cut=sscale_ele(rij)
14504             sss_ele_grad=sscagrad_ele(rij)
14505             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14506             if (sss_ele_cut.le.0.0) cycle
14507           if (sss.gt.0.0d0) then
14508             rmij=1.0D0/rij
14509             r3ij=rrmij*rmij
14510             r6ij=r3ij*r3ij
14511             ev1=aaa*r6ij*r6ij
14512 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14513             if (j.eq.i+2) ev1=scal_el*ev1
14514             ev2=bbb*r6ij
14515             evdwij=ev1+ev2
14516             if (energy_dec) then
14517               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14518             endif
14519             evdw1=evdw1+evdwij*sss*sss_ele_cut
14520 !
14521 ! Calculate contributions to the Cartesian gradient.
14522 !
14523             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
14524 !            ggg(1)=facvdw*xj
14525 !            ggg(2)=facvdw*yj
14526 !            ggg(3)=facvdw*zj
14527           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
14528           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14529           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
14530           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14531           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
14532           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14533
14534             do k=1,3
14535               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14536               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14537             enddo
14538           endif
14539         enddo ! j
14540       enddo   ! i
14541       return
14542       end subroutine evdwpp_short
14543 !-----------------------------------------------------------------------------
14544       subroutine escp_long(evdw2,evdw2_14)
14545 !
14546 ! This subroutine calculates the excluded-volume interaction energy between
14547 ! peptide-group centers and side chains and its gradient in virtual-bond and
14548 ! side-chain vectors.
14549 !
14550 !      implicit real*8 (a-h,o-z)
14551 !      include 'DIMENSIONS'
14552 !      include 'COMMON.GEO'
14553 !      include 'COMMON.VAR'
14554 !      include 'COMMON.LOCAL'
14555 !      include 'COMMON.CHAIN'
14556 !      include 'COMMON.DERIV'
14557 !      include 'COMMON.INTERACT'
14558 !      include 'COMMON.FFIELD'
14559 !      include 'COMMON.IOUNITS'
14560 !      include 'COMMON.CONTROL'
14561       real(kind=8),dimension(3) :: ggg
14562 !el local variables
14563       integer :: i,iint,j,k,iteli,itypj,subchap
14564       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
14565       real(kind=8) :: evdw2,evdw2_14,evdwij
14566       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14567                     dist_temp, dist_init
14568
14569       evdw2=0.0D0
14570       evdw2_14=0.0d0
14571 !d    print '(a)','Enter ESCP'
14572 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
14573       do i=iatscp_s,iatscp_e
14574         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
14575         iteli=itel(i)
14576         xi=0.5D0*(c(1,i)+c(1,i+1))
14577         yi=0.5D0*(c(2,i)+c(2,i+1))
14578         zi=0.5D0*(c(3,i)+c(3,i+1))
14579           xi=mod(xi,boxxsize)
14580           if (xi.lt.0) xi=xi+boxxsize
14581           yi=mod(yi,boxysize)
14582           if (yi.lt.0) yi=yi+boxysize
14583           zi=mod(zi,boxzsize)
14584           if (zi.lt.0) zi=zi+boxzsize
14585
14586         do iint=1,nscp_gr(i)
14587
14588         do j=iscpstart(i,iint),iscpend(i,iint)
14589           itypj=itype(j)
14590           if (itypj.eq.ntyp1) cycle
14591 ! Uncomment following three lines for SC-p interactions
14592 !         xj=c(1,nres+j)-xi
14593 !         yj=c(2,nres+j)-yi
14594 !         zj=c(3,nres+j)-zi
14595 ! Uncomment following three lines for Ca-p interactions
14596           xj=c(1,j)
14597           yj=c(2,j)
14598           zj=c(3,j)
14599           xj=mod(xj,boxxsize)
14600           if (xj.lt.0) xj=xj+boxxsize
14601           yj=mod(yj,boxysize)
14602           if (yj.lt.0) yj=yj+boxysize
14603           zj=mod(zj,boxzsize)
14604           if (zj.lt.0) zj=zj+boxzsize
14605       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14606       xj_safe=xj
14607       yj_safe=yj
14608       zj_safe=zj
14609       subchap=0
14610       do xshift=-1,1
14611       do yshift=-1,1
14612       do zshift=-1,1
14613           xj=xj_safe+xshift*boxxsize
14614           yj=yj_safe+yshift*boxysize
14615           zj=zj_safe+zshift*boxzsize
14616           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14617           if(dist_temp.lt.dist_init) then
14618             dist_init=dist_temp
14619             xj_temp=xj
14620             yj_temp=yj
14621             zj_temp=zj
14622             subchap=1
14623           endif
14624        enddo
14625        enddo
14626        enddo
14627        if (subchap.eq.1) then
14628           xj=xj_temp-xi
14629           yj=yj_temp-yi
14630           zj=zj_temp-zi
14631        else
14632           xj=xj_safe-xi
14633           yj=yj_safe-yi
14634           zj=zj_safe-zi
14635        endif
14636           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14637
14638           rij=dsqrt(1.0d0/rrij)
14639             sss_ele_cut=sscale_ele(rij)
14640             sss_ele_grad=sscagrad_ele(rij)
14641 !            print *,sss_ele_cut,sss_ele_grad,&
14642 !            (rij),r_cut_ele,rlamb_ele
14643             if (sss_ele_cut.le.0.0) cycle
14644           sss=sscale((rij/rscp(itypj,iteli)))
14645           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
14646           if (sss.lt.1.0d0) then
14647
14648             fac=rrij**expon2
14649             e1=fac*fac*aad(itypj,iteli)
14650             e2=fac*bad(itypj,iteli)
14651             if (iabs(j-i) .le. 2) then
14652               e1=scal14*e1
14653               e2=scal14*e2
14654               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
14655             endif
14656             evdwij=e1+e2
14657             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
14658             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
14659                 'evdw2',i,j,sss,evdwij
14660 !
14661 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
14662 !
14663             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
14664             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
14665             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
14666             ggg(1)=xj*fac
14667             ggg(2)=yj*fac
14668             ggg(3)=zj*fac
14669 ! Uncomment following three lines for SC-p interactions
14670 !           do k=1,3
14671 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14672 !           enddo
14673 ! Uncomment following line for SC-p interactions
14674 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14675             do k=1,3
14676               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
14677               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
14678             enddo
14679           endif
14680         enddo
14681
14682         enddo ! iint
14683       enddo ! i
14684       do i=1,nct
14685         do j=1,3
14686           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
14687           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
14688           gradx_scp(j,i)=expon*gradx_scp(j,i)
14689         enddo
14690       enddo
14691 !******************************************************************************
14692 !
14693 !                              N O T E !!!
14694 !
14695 ! To save time the factor EXPON has been extracted from ALL components
14696 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14697 ! use!
14698 !
14699 !******************************************************************************
14700       return
14701       end subroutine escp_long
14702 !-----------------------------------------------------------------------------
14703       subroutine escp_short(evdw2,evdw2_14)
14704 !
14705 ! This subroutine calculates the excluded-volume interaction energy between
14706 ! peptide-group centers and side chains and its gradient in virtual-bond and
14707 ! side-chain vectors.
14708 !
14709 !      implicit real*8 (a-h,o-z)
14710 !      include 'DIMENSIONS'
14711 !      include 'COMMON.GEO'
14712 !      include 'COMMON.VAR'
14713 !      include 'COMMON.LOCAL'
14714 !      include 'COMMON.CHAIN'
14715 !      include 'COMMON.DERIV'
14716 !      include 'COMMON.INTERACT'
14717 !      include 'COMMON.FFIELD'
14718 !      include 'COMMON.IOUNITS'
14719 !      include 'COMMON.CONTROL'
14720       real(kind=8),dimension(3) :: ggg
14721 !el local variables
14722       integer :: i,iint,j,k,iteli,itypj,subchap
14723       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
14724       real(kind=8) :: evdw2,evdw2_14,evdwij
14725       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14726                     dist_temp, dist_init
14727
14728       evdw2=0.0D0
14729       evdw2_14=0.0d0
14730 !d    print '(a)','Enter ESCP'
14731 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
14732       do i=iatscp_s,iatscp_e
14733         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
14734         iteli=itel(i)
14735         xi=0.5D0*(c(1,i)+c(1,i+1))
14736         yi=0.5D0*(c(2,i)+c(2,i+1))
14737         zi=0.5D0*(c(3,i)+c(3,i+1))
14738           xi=mod(xi,boxxsize)
14739           if (xi.lt.0) xi=xi+boxxsize
14740           yi=mod(yi,boxysize)
14741           if (yi.lt.0) yi=yi+boxysize
14742           zi=mod(zi,boxzsize)
14743           if (zi.lt.0) zi=zi+boxzsize
14744
14745         do iint=1,nscp_gr(i)
14746
14747         do j=iscpstart(i,iint),iscpend(i,iint)
14748           itypj=itype(j)
14749           if (itypj.eq.ntyp1) cycle
14750 ! Uncomment following three lines for SC-p interactions
14751 !         xj=c(1,nres+j)-xi
14752 !         yj=c(2,nres+j)-yi
14753 !         zj=c(3,nres+j)-zi
14754 ! Uncomment following three lines for Ca-p interactions
14755 !          xj=c(1,j)-xi
14756 !          yj=c(2,j)-yi
14757 !          zj=c(3,j)-zi
14758           xj=c(1,j)
14759           yj=c(2,j)
14760           zj=c(3,j)
14761           xj=mod(xj,boxxsize)
14762           if (xj.lt.0) xj=xj+boxxsize
14763           yj=mod(yj,boxysize)
14764           if (yj.lt.0) yj=yj+boxysize
14765           zj=mod(zj,boxzsize)
14766           if (zj.lt.0) zj=zj+boxzsize
14767       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14768       xj_safe=xj
14769       yj_safe=yj
14770       zj_safe=zj
14771       subchap=0
14772       do xshift=-1,1
14773       do yshift=-1,1
14774       do zshift=-1,1
14775           xj=xj_safe+xshift*boxxsize
14776           yj=yj_safe+yshift*boxysize
14777           zj=zj_safe+zshift*boxzsize
14778           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14779           if(dist_temp.lt.dist_init) then
14780             dist_init=dist_temp
14781             xj_temp=xj
14782             yj_temp=yj
14783             zj_temp=zj
14784             subchap=1
14785           endif
14786        enddo
14787        enddo
14788        enddo
14789        if (subchap.eq.1) then
14790           xj=xj_temp-xi
14791           yj=yj_temp-yi
14792           zj=zj_temp-zi
14793        else
14794           xj=xj_safe-xi
14795           yj=yj_safe-yi
14796           zj=zj_safe-zi
14797        endif
14798
14799           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14800           rij=dsqrt(1.0d0/rrij)
14801             sss_ele_cut=sscale_ele(rij)
14802             sss_ele_grad=sscagrad_ele(rij)
14803 !            print *,sss_ele_cut,sss_ele_grad,&
14804 !            (rij),r_cut_ele,rlamb_ele
14805             if (sss_ele_cut.le.0.0) cycle
14806           sss=sscale(rij/rscp(itypj,iteli))
14807           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
14808           if (sss.gt.0.0d0) then
14809
14810             fac=rrij**expon2
14811             e1=fac*fac*aad(itypj,iteli)
14812             e2=fac*bad(itypj,iteli)
14813             if (iabs(j-i) .le. 2) then
14814               e1=scal14*e1
14815               e2=scal14*e2
14816               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
14817             endif
14818             evdwij=e1+e2
14819             evdw2=evdw2+evdwij*sss*sss_ele_cut
14820             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
14821                 'evdw2',i,j,sss,evdwij
14822 !
14823 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
14824 !
14825             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
14826             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
14827             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
14828
14829             ggg(1)=xj*fac
14830             ggg(2)=yj*fac
14831             ggg(3)=zj*fac
14832 ! Uncomment following three lines for SC-p interactions
14833 !           do k=1,3
14834 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14835 !           enddo
14836 ! Uncomment following line for SC-p interactions
14837 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
14838             do k=1,3
14839               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
14840               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
14841             enddo
14842           endif
14843         enddo
14844
14845         enddo ! iint
14846       enddo ! i
14847       do i=1,nct
14848         do j=1,3
14849           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
14850           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
14851           gradx_scp(j,i)=expon*gradx_scp(j,i)
14852         enddo
14853       enddo
14854 !******************************************************************************
14855 !
14856 !                              N O T E !!!
14857 !
14858 ! To save time the factor EXPON has been extracted from ALL components
14859 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14860 ! use!
14861 !
14862 !******************************************************************************
14863       return
14864       end subroutine escp_short
14865 !-----------------------------------------------------------------------------
14866 ! energy_p_new-sep_barrier.F
14867 !-----------------------------------------------------------------------------
14868       subroutine sc_grad_scale(scalfac)
14869 !      implicit real*8 (a-h,o-z)
14870       use calc_data
14871 !      include 'DIMENSIONS'
14872 !      include 'COMMON.CHAIN'
14873 !      include 'COMMON.DERIV'
14874 !      include 'COMMON.CALC'
14875 !      include 'COMMON.IOUNITS'
14876       real(kind=8),dimension(3) :: dcosom1,dcosom2
14877       real(kind=8) :: scalfac
14878 !el local variables
14879 !      integer :: i,j,k,l
14880
14881       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
14882       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
14883       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
14884            -2.0D0*alf12*eps3der+sigder*sigsq_om12
14885 ! diagnostics only
14886 !      eom1=0.0d0
14887 !      eom2=0.0d0
14888 !      eom12=evdwij*eps1_om12
14889 ! end diagnostics
14890 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
14891 !     &  " sigder",sigder
14892 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
14893 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
14894       do k=1,3
14895         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
14896         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
14897       enddo
14898       do k=1,3
14899         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
14900          *sss_ele_cut
14901       enddo
14902 !      write (iout,*) "gg",(gg(k),k=1,3)
14903       do k=1,3
14904         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
14905                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
14906                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
14907                  *sss_ele_cut
14908         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
14909                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
14910                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
14911          *sss_ele_cut
14912 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
14913 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
14914 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
14915 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
14916       enddo
14917 !
14918 ! Calculate the components of the gradient in DC and X
14919 !
14920       do l=1,3
14921         gvdwc(l,i)=gvdwc(l,i)-gg(l)
14922         gvdwc(l,j)=gvdwc(l,j)+gg(l)
14923       enddo
14924       return
14925       end subroutine sc_grad_scale
14926 !-----------------------------------------------------------------------------
14927 ! energy_split-sep.F
14928 !-----------------------------------------------------------------------------
14929       subroutine etotal_long(energia)
14930 !
14931 ! Compute the long-range slow-varying contributions to the energy
14932 !
14933 !      implicit real*8 (a-h,o-z)
14934 !      include 'DIMENSIONS'
14935       use MD_data, only: totT,usampl,eq_time
14936 #ifndef ISNAN
14937       external proc_proc
14938 #ifdef WINPGI
14939 !MS$ATTRIBUTES C ::  proc_proc
14940 #endif
14941 #endif
14942 #ifdef MPI
14943       include "mpif.h"
14944       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
14945 #endif
14946 !      include 'COMMON.SETUP'
14947 !      include 'COMMON.IOUNITS'
14948 !      include 'COMMON.FFIELD'
14949 !      include 'COMMON.DERIV'
14950 !      include 'COMMON.INTERACT'
14951 !      include 'COMMON.SBRIDGE'
14952 !      include 'COMMON.CHAIN'
14953 !      include 'COMMON.VAR'
14954 !      include 'COMMON.LOCAL'
14955 !      include 'COMMON.MD'
14956       real(kind=8),dimension(0:n_ene) :: energia
14957 !el local variables
14958       integer :: i,n_corr,n_corr1,ierror,ierr
14959       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
14960                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
14961                   ecorr,ecorr5,ecorr6,eturn6,time00
14962 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
14963 !elwrite(iout,*)"in etotal long"
14964
14965       if (modecalc.eq.12.or.modecalc.eq.14) then
14966 #ifdef MPI
14967 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
14968 #else
14969         call int_from_cart1(.false.)
14970 #endif
14971       endif
14972 !elwrite(iout,*)"in etotal long"
14973
14974 #ifdef MPI
14975 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
14976 !     & " absolute rank",myrank," nfgtasks",nfgtasks
14977       call flush(iout)
14978       if (nfgtasks.gt.1) then
14979         time00=MPI_Wtime()
14980 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
14981         if (fg_rank.eq.0) then
14982           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
14983 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
14984 !          call flush(iout)
14985 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
14986 ! FG slaves as WEIGHTS array.
14987           weights_(1)=wsc
14988           weights_(2)=wscp
14989           weights_(3)=welec
14990           weights_(4)=wcorr
14991           weights_(5)=wcorr5
14992           weights_(6)=wcorr6
14993           weights_(7)=wel_loc
14994           weights_(8)=wturn3
14995           weights_(9)=wturn4
14996           weights_(10)=wturn6
14997           weights_(11)=wang
14998           weights_(12)=wscloc
14999           weights_(13)=wtor
15000           weights_(14)=wtor_d
15001           weights_(15)=wstrain
15002           weights_(16)=wvdwpp
15003           weights_(17)=wbond
15004           weights_(18)=scal14
15005           weights_(21)=wsccor
15006 ! FG Master broadcasts the WEIGHTS_ array
15007           call MPI_Bcast(weights_(1),n_ene,&
15008               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15009         else
15010 ! FG slaves receive the WEIGHTS array
15011           call MPI_Bcast(weights(1),n_ene,&
15012               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15013           wsc=weights(1)
15014           wscp=weights(2)
15015           welec=weights(3)
15016           wcorr=weights(4)
15017           wcorr5=weights(5)
15018           wcorr6=weights(6)
15019           wel_loc=weights(7)
15020           wturn3=weights(8)
15021           wturn4=weights(9)
15022           wturn6=weights(10)
15023           wang=weights(11)
15024           wscloc=weights(12)
15025           wtor=weights(13)
15026           wtor_d=weights(14)
15027           wstrain=weights(15)
15028           wvdwpp=weights(16)
15029           wbond=weights(17)
15030           scal14=weights(18)
15031           wsccor=weights(21)
15032         endif
15033         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15034           king,FG_COMM,IERR)
15035          time_Bcast=time_Bcast+MPI_Wtime()-time00
15036          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15037 !        call chainbuild_cart
15038 !        call int_from_cart1(.false.)
15039       endif
15040 !      write (iout,*) 'Processor',myrank,
15041 !     &  ' calling etotal_short ipot=',ipot
15042 !      call flush(iout)
15043 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15044 #endif
15045 !d    print *,'nnt=',nnt,' nct=',nct
15046 !
15047 !elwrite(iout,*)"in etotal long"
15048 ! Compute the side-chain and electrostatic interaction energy
15049 !
15050       goto (101,102,103,104,105,106) ipot
15051 ! Lennard-Jones potential.
15052   101 call elj_long(evdw)
15053 !d    print '(a)','Exit ELJ'
15054       goto 107
15055 ! Lennard-Jones-Kihara potential (shifted).
15056   102 call eljk_long(evdw)
15057       goto 107
15058 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15059   103 call ebp_long(evdw)
15060       goto 107
15061 ! Gay-Berne potential (shifted LJ, angular dependence).
15062   104 call egb_long(evdw)
15063       goto 107
15064 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15065   105 call egbv_long(evdw)
15066       goto 107
15067 ! Soft-sphere potential
15068   106 call e_softsphere(evdw)
15069 !
15070 ! Calculate electrostatic (H-bonding) energy of the main chain.
15071 !
15072   107 continue
15073       call vec_and_deriv
15074       if (ipot.lt.6) then
15075 #ifdef SPLITELE
15076          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15077              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15078              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15079              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15080 #else
15081          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15082              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15083              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15084              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15085 #endif
15086            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15087          else
15088             ees=0
15089             evdw1=0
15090             eel_loc=0
15091             eello_turn3=0
15092             eello_turn4=0
15093          endif
15094       else
15095 !        write (iout,*) "Soft-spheer ELEC potential"
15096         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15097          eello_turn4)
15098       endif
15099 !
15100 ! Calculate excluded-volume interaction energy between peptide groups
15101 ! and side chains.
15102 !
15103       if (ipot.lt.6) then
15104        if(wscp.gt.0d0) then
15105         call escp_long(evdw2,evdw2_14)
15106        else
15107         evdw2=0
15108         evdw2_14=0
15109        endif
15110       else
15111         call escp_soft_sphere(evdw2,evdw2_14)
15112       endif
15113 !
15114 ! 12/1/95 Multi-body terms
15115 !
15116       n_corr=0
15117       n_corr1=0
15118       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15119           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15120          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15121 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15122 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15123       else
15124          ecorr=0.0d0
15125          ecorr5=0.0d0
15126          ecorr6=0.0d0
15127          eturn6=0.0d0
15128       endif
15129       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15130          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15131       endif
15132 !
15133 ! If performing constraint dynamics, call the constraint energy
15134 !  after the equilibration time
15135       if(usampl.and.totT.gt.eq_time) then
15136          call EconstrQ
15137          call Econstr_back
15138       else
15139          Uconst=0.0d0
15140          Uconst_back=0.0d0
15141       endif
15142 !
15143 ! Sum the energies
15144 !
15145       do i=1,n_ene
15146         energia(i)=0.0d0
15147       enddo
15148       energia(1)=evdw
15149 #ifdef SCP14
15150       energia(2)=evdw2-evdw2_14
15151       energia(18)=evdw2_14
15152 #else
15153       energia(2)=evdw2
15154       energia(18)=0.0d0
15155 #endif
15156 #ifdef SPLITELE
15157       energia(3)=ees
15158       energia(16)=evdw1
15159 #else
15160       energia(3)=ees+evdw1
15161       energia(16)=0.0d0
15162 #endif
15163       energia(4)=ecorr
15164       energia(5)=ecorr5
15165       energia(6)=ecorr6
15166       energia(7)=eel_loc
15167       energia(8)=eello_turn3
15168       energia(9)=eello_turn4
15169       energia(10)=eturn6
15170       energia(20)=Uconst+Uconst_back
15171       call sum_energy(energia,.true.)
15172 !      write (iout,*) "Exit ETOTAL_LONG"
15173       call flush(iout)
15174       return
15175       end subroutine etotal_long
15176 !-----------------------------------------------------------------------------
15177       subroutine etotal_short(energia)
15178 !
15179 ! Compute the short-range fast-varying contributions to the energy
15180 !
15181 !      implicit real*8 (a-h,o-z)
15182 !      include 'DIMENSIONS'
15183 #ifndef ISNAN
15184       external proc_proc
15185 #ifdef WINPGI
15186 !MS$ATTRIBUTES C ::  proc_proc
15187 #endif
15188 #endif
15189 #ifdef MPI
15190       include "mpif.h"
15191       integer :: ierror,ierr
15192       real(kind=8),dimension(n_ene) :: weights_
15193       real(kind=8) :: time00
15194 #endif
15195 !      include 'COMMON.SETUP'
15196 !      include 'COMMON.IOUNITS'
15197 !      include 'COMMON.FFIELD'
15198 !      include 'COMMON.DERIV'
15199 !      include 'COMMON.INTERACT'
15200 !      include 'COMMON.SBRIDGE'
15201 !      include 'COMMON.CHAIN'
15202 !      include 'COMMON.VAR'
15203 !      include 'COMMON.LOCAL'
15204       real(kind=8),dimension(0:n_ene) :: energia
15205 !el local variables
15206       integer :: i,nres6
15207       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15208       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr
15209       nres6=6*nres
15210
15211 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15212 !      call flush(iout)
15213       if (modecalc.eq.12.or.modecalc.eq.14) then
15214 #ifdef MPI
15215         if (fg_rank.eq.0) call int_from_cart1(.false.)
15216 #else
15217         call int_from_cart1(.false.)
15218 #endif
15219       endif
15220 #ifdef MPI
15221 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15222 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15223 !      call flush(iout)
15224       if (nfgtasks.gt.1) then
15225         time00=MPI_Wtime()
15226 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15227         if (fg_rank.eq.0) then
15228           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15229 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15230 !          call flush(iout)
15231 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15232 ! FG slaves as WEIGHTS array.
15233           weights_(1)=wsc
15234           weights_(2)=wscp
15235           weights_(3)=welec
15236           weights_(4)=wcorr
15237           weights_(5)=wcorr5
15238           weights_(6)=wcorr6
15239           weights_(7)=wel_loc
15240           weights_(8)=wturn3
15241           weights_(9)=wturn4
15242           weights_(10)=wturn6
15243           weights_(11)=wang
15244           weights_(12)=wscloc
15245           weights_(13)=wtor
15246           weights_(14)=wtor_d
15247           weights_(15)=wstrain
15248           weights_(16)=wvdwpp
15249           weights_(17)=wbond
15250           weights_(18)=scal14
15251           weights_(21)=wsccor
15252 ! FG Master broadcasts the WEIGHTS_ array
15253           call MPI_Bcast(weights_(1),n_ene,&
15254               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15255         else
15256 ! FG slaves receive the WEIGHTS array
15257           call MPI_Bcast(weights(1),n_ene,&
15258               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15259           wsc=weights(1)
15260           wscp=weights(2)
15261           welec=weights(3)
15262           wcorr=weights(4)
15263           wcorr5=weights(5)
15264           wcorr6=weights(6)
15265           wel_loc=weights(7)
15266           wturn3=weights(8)
15267           wturn4=weights(9)
15268           wturn6=weights(10)
15269           wang=weights(11)
15270           wscloc=weights(12)
15271           wtor=weights(13)
15272           wtor_d=weights(14)
15273           wstrain=weights(15)
15274           wvdwpp=weights(16)
15275           wbond=weights(17)
15276           scal14=weights(18)
15277           wsccor=weights(21)
15278         endif
15279 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15280         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15281           king,FG_COMM,IERR)
15282 !        write (iout,*) "Processor",myrank," BROADCAST c"
15283         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15284           king,FG_COMM,IERR)
15285 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15286         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15287           king,FG_COMM,IERR)
15288 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15289         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15290           king,FG_COMM,IERR)
15291 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15292         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15293           king,FG_COMM,IERR)
15294 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15295         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15296           king,FG_COMM,IERR)
15297 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15298         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15299           king,FG_COMM,IERR)
15300 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15301         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15302           king,FG_COMM,IERR)
15303 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15304         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15305           king,FG_COMM,IERR)
15306          time_Bcast=time_Bcast+MPI_Wtime()-time00
15307 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15308       endif
15309 !      write (iout,*) 'Processor',myrank,
15310 !     &  ' calling etotal_short ipot=',ipot
15311 !      call flush(iout)
15312 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15313 #endif
15314 !      call int_from_cart1(.false.)
15315 !
15316 ! Compute the side-chain and electrostatic interaction energy
15317 !
15318       goto (101,102,103,104,105,106) ipot
15319 ! Lennard-Jones potential.
15320   101 call elj_short(evdw)
15321 !d    print '(a)','Exit ELJ'
15322       goto 107
15323 ! Lennard-Jones-Kihara potential (shifted).
15324   102 call eljk_short(evdw)
15325       goto 107
15326 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15327   103 call ebp_short(evdw)
15328       goto 107
15329 ! Gay-Berne potential (shifted LJ, angular dependence).
15330   104 call egb_short(evdw)
15331       goto 107
15332 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15333   105 call egbv_short(evdw)
15334       goto 107
15335 ! Soft-sphere potential - already dealt with in the long-range part
15336   106 evdw=0.0d0
15337 !  106 call e_softsphere_short(evdw)
15338 !
15339 ! Calculate electrostatic (H-bonding) energy of the main chain.
15340 !
15341   107 continue
15342 !
15343 ! Calculate the short-range part of Evdwpp
15344 !
15345       call evdwpp_short(evdw1)
15346 !
15347 ! Calculate the short-range part of ESCp
15348 !
15349       if (ipot.lt.6) then
15350         call escp_short(evdw2,evdw2_14)
15351       endif
15352 !
15353 ! Calculate the bond-stretching energy
15354 !
15355       call ebond(estr)
15356 !
15357 ! Calculate the disulfide-bridge and other energy and the contributions
15358 ! from other distance constraints.
15359       call edis(ehpb)
15360 !
15361 ! Calculate the virtual-bond-angle energy.
15362 !
15363       call ebend(ebe)
15364 !
15365 ! Calculate the SC local energy.
15366 !
15367       call vec_and_deriv
15368       call esc(escloc)
15369 !
15370 ! Calculate the virtual-bond torsional energy.
15371 !
15372       call etor(etors,edihcnstr)
15373 !
15374 ! 6/23/01 Calculate double-torsional energy
15375 !
15376       call etor_d(etors_d)
15377 !
15378 ! 21/5/07 Calculate local sicdechain correlation energy
15379 !
15380       if (wsccor.gt.0.0d0) then
15381         call eback_sc_corr(esccor)
15382       else
15383         esccor=0.0d0
15384       endif
15385 !
15386 ! Put energy components into an array
15387 !
15388       do i=1,n_ene
15389         energia(i)=0.0d0
15390       enddo
15391       energia(1)=evdw
15392 #ifdef SCP14
15393       energia(2)=evdw2-evdw2_14
15394       energia(18)=evdw2_14
15395 #else
15396       energia(2)=evdw2
15397       energia(18)=0.0d0
15398 #endif
15399 #ifdef SPLITELE
15400       energia(16)=evdw1
15401 #else
15402       energia(3)=evdw1
15403 #endif
15404       energia(11)=ebe
15405       energia(12)=escloc
15406       energia(13)=etors
15407       energia(14)=etors_d
15408       energia(15)=ehpb
15409       energia(17)=estr
15410       energia(19)=edihcnstr
15411       energia(21)=esccor
15412 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15413       call flush(iout)
15414       call sum_energy(energia,.true.)
15415 !      write (iout,*) "Exit ETOTAL_SHORT"
15416       call flush(iout)
15417       return
15418       end subroutine etotal_short
15419 !-----------------------------------------------------------------------------
15420 ! gnmr1.f
15421 !-----------------------------------------------------------------------------
15422       real(kind=8) function gnmr1(y,ymin,ymax)
15423 !      implicit none
15424       real(kind=8) :: y,ymin,ymax
15425       real(kind=8) :: wykl=4.0d0
15426       if (y.lt.ymin) then
15427         gnmr1=(ymin-y)**wykl/wykl
15428       else if (y.gt.ymax) then
15429         gnmr1=(y-ymax)**wykl/wykl
15430       else
15431         gnmr1=0.0d0
15432       endif
15433       return
15434       end function gnmr1
15435 !-----------------------------------------------------------------------------
15436       real(kind=8) function gnmr1prim(y,ymin,ymax)
15437 !      implicit none
15438       real(kind=8) :: y,ymin,ymax
15439       real(kind=8) :: wykl=4.0d0
15440       if (y.lt.ymin) then
15441         gnmr1prim=-(ymin-y)**(wykl-1)
15442       else if (y.gt.ymax) then
15443         gnmr1prim=(y-ymax)**(wykl-1)
15444       else
15445         gnmr1prim=0.0d0
15446       endif
15447       return
15448       end function gnmr1prim
15449 !-----------------------------------------------------------------------------
15450       real(kind=8) function harmonic(y,ymax)
15451 !      implicit none
15452       real(kind=8) :: y,ymax
15453       real(kind=8) :: wykl=2.0d0
15454       harmonic=(y-ymax)**wykl
15455       return
15456       end function harmonic
15457 !-----------------------------------------------------------------------------
15458       real(kind=8) function harmonicprim(y,ymax)
15459       real(kind=8) :: y,ymin,ymax
15460       real(kind=8) :: wykl=2.0d0
15461       harmonicprim=(y-ymax)*wykl
15462       return
15463       end function harmonicprim
15464 !-----------------------------------------------------------------------------
15465 ! gradient_p.F
15466 !-----------------------------------------------------------------------------
15467       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
15468
15469       use io_base, only:intout,briefout
15470 !      implicit real*8 (a-h,o-z)
15471 !      include 'DIMENSIONS'
15472 !      include 'COMMON.CHAIN'
15473 !      include 'COMMON.DERIV'
15474 !      include 'COMMON.VAR'
15475 !      include 'COMMON.INTERACT'
15476 !      include 'COMMON.FFIELD'
15477 !      include 'COMMON.MD'
15478 !      include 'COMMON.IOUNITS'
15479       real(kind=8),external :: ufparm
15480       integer :: uiparm(1)
15481       real(kind=8) :: urparm(1)
15482       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
15483       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
15484       integer :: n,nf,ind,ind1,i,k,j
15485 !
15486 ! This subroutine calculates total internal coordinate gradient.
15487 ! Depending on the number of function evaluations, either whole energy
15488 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
15489 ! internal coordinates are reevaluated or only the cartesian-in-internal
15490 ! coordinate derivatives are evaluated. The subroutine was designed to work
15491 ! with SUMSL.
15492 !
15493 !
15494       icg=mod(nf,2)+1
15495
15496 !d      print *,'grad',nf,icg
15497       if (nf-nfl+1) 20,30,40
15498    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
15499 !    write (iout,*) 'grad 20'
15500       if (nf.eq.0) return
15501       goto 40
15502    30 call var_to_geom(n,x)
15503       call chainbuild
15504 !    write (iout,*) 'grad 30'
15505 !
15506 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
15507 !
15508    40 call cartder
15509 !     write (iout,*) 'grad 40'
15510 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
15511 !
15512 ! Convert the Cartesian gradient into internal-coordinate gradient.
15513 !
15514       ind=0
15515       ind1=0
15516       do i=1,nres-2
15517         gthetai=0.0D0
15518         gphii=0.0D0
15519         do j=i+1,nres-1
15520           ind=ind+1
15521 !         ind=indmat(i,j)
15522 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
15523           do k=1,3
15524             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
15525           enddo
15526           do k=1,3
15527             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
15528           enddo
15529         enddo
15530         do j=i+1,nres-1
15531           ind1=ind1+1
15532 !         ind1=indmat(i,j)
15533 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
15534           do k=1,3
15535             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
15536             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
15537           enddo
15538         enddo
15539         if (i.gt.1) g(i-1)=gphii
15540         if (n.gt.nphi) g(nphi+i)=gthetai
15541       enddo
15542       if (n.le.nphi+ntheta) goto 10
15543       do i=2,nres-1
15544         if (itype(i).ne.10) then
15545           galphai=0.0D0
15546           gomegai=0.0D0
15547           do k=1,3
15548             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
15549           enddo
15550           do k=1,3
15551             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
15552           enddo
15553           g(ialph(i,1))=galphai
15554           g(ialph(i,1)+nside)=gomegai
15555         endif
15556       enddo
15557 !
15558 ! Add the components corresponding to local energy terms.
15559 !
15560    10 continue
15561       do i=1,nvar
15562 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
15563         g(i)=g(i)+gloc(i,icg)
15564       enddo
15565 ! Uncomment following three lines for diagnostics.
15566 !d    call intout
15567 !elwrite(iout,*) "in gradient after calling intout"
15568 !d    call briefout(0,0.0d0)
15569 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
15570       return
15571       end subroutine gradient
15572 !-----------------------------------------------------------------------------
15573       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
15574
15575       use comm_chu
15576 !      implicit real*8 (a-h,o-z)
15577 !      include 'DIMENSIONS'
15578 !      include 'COMMON.DERIV'
15579 !      include 'COMMON.IOUNITS'
15580 !      include 'COMMON.GEO'
15581       integer :: n,nf
15582 !el      integer :: jjj
15583 !el      common /chuju/ jjj
15584       real(kind=8) :: energia(0:n_ene)
15585       integer :: uiparm(1)
15586       real(kind=8) :: urparm(1)
15587       real(kind=8) :: f
15588       real(kind=8),external :: ufparm
15589       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
15590 !     if (jjj.gt.0) then
15591 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15592 !     endif
15593       nfl=nf
15594       icg=mod(nf,2)+1
15595 !d      print *,'func',nf,nfl,icg
15596       call var_to_geom(n,x)
15597       call zerograd
15598       call chainbuild
15599 !d    write (iout,*) 'ETOTAL called from FUNC'
15600       call etotal(energia)
15601       call sum_gradient
15602       f=energia(0)
15603 !     if (jjj.gt.0) then
15604 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15605 !       write (iout,*) 'f=',etot
15606 !       jjj=0
15607 !     endif
15608       return
15609       end subroutine func
15610 !-----------------------------------------------------------------------------
15611       subroutine cartgrad
15612 !      implicit real*8 (a-h,o-z)
15613 !      include 'DIMENSIONS'
15614       use energy_data
15615       use MD_data, only: totT,usampl,eq_time
15616 #ifdef MPI
15617       include 'mpif.h'
15618 #endif
15619 !      include 'COMMON.CHAIN'
15620 !      include 'COMMON.DERIV'
15621 !      include 'COMMON.VAR'
15622 !      include 'COMMON.INTERACT'
15623 !      include 'COMMON.FFIELD'
15624 !      include 'COMMON.MD'
15625 !      include 'COMMON.IOUNITS'
15626 !      include 'COMMON.TIME1'
15627 !
15628       integer :: i,j
15629
15630 ! This subrouting calculates total Cartesian coordinate gradient.
15631 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
15632 !
15633 !el#define DEBUG
15634 #ifdef TIMING
15635       time00=MPI_Wtime()
15636 #endif
15637       icg=1
15638       call sum_gradient
15639 #ifdef TIMING
15640 #endif
15641 !el      write (iout,*) "After sum_gradient"
15642 #ifdef DEBUG
15643 !el      write (iout,*) "After sum_gradient"
15644       do i=1,nres-1
15645         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
15646         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
15647       enddo
15648 #endif
15649 ! If performing constraint dynamics, add the gradients of the constraint energy
15650       if(usampl.and.totT.gt.eq_time) then
15651          do i=1,nct
15652            do j=1,3
15653              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
15654              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
15655            enddo
15656          enddo
15657          do i=1,nres-3
15658            gloc(i,icg)=gloc(i,icg)+dugamma(i)
15659          enddo
15660          do i=1,nres-2
15661            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
15662          enddo
15663       endif
15664 !elwrite (iout,*) "After sum_gradient"
15665 #ifdef TIMING
15666       time01=MPI_Wtime()
15667 #endif
15668       call intcartderiv
15669 !elwrite (iout,*) "After sum_gradient"
15670 #ifdef TIMING
15671       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
15672 #endif
15673 !     call checkintcartgrad
15674 !     write(iout,*) 'calling int_to_cart'
15675 #ifdef DEBUG
15676       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
15677 #endif
15678       do i=1,nct
15679         do j=1,3
15680           gcart(j,i)=gradc(j,i,icg)
15681           gxcart(j,i)=gradx(j,i,icg)
15682         enddo
15683 #ifdef DEBUG
15684         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
15685           (gxcart(j,i),j=1,3),gloc(i,icg)
15686 #endif
15687       enddo
15688 #ifdef TIMING
15689       time01=MPI_Wtime()
15690 #endif
15691       call int_to_cart
15692 #ifdef TIMING
15693       time_inttocart=time_inttocart+MPI_Wtime()-time01
15694 #endif
15695 #ifdef DEBUG
15696       write (iout,*) "gcart and gxcart after int_to_cart"
15697       do i=0,nres-1
15698         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
15699             (gxcart(j,i),j=1,3)
15700       enddo
15701 #endif
15702 #ifdef CARGRAD
15703 #ifdef DEBUG
15704       write (iout,*) "CARGRAD"
15705 #endif
15706       do i=nres,1,-1
15707         do j=1,3
15708           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
15709 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
15710         enddo
15711 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
15712 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
15713       enddo
15714 ! Correction: dummy residues
15715         if (nnt.gt.1) then
15716           do j=1,3
15717 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
15718             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
15719           enddo
15720         endif
15721         if (nct.lt.nres) then
15722           do j=1,3
15723 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
15724             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
15725           enddo
15726         endif
15727 #endif
15728 #ifdef TIMING
15729       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
15730 #endif
15731 !el#undef DEBUG
15732       return
15733       end subroutine cartgrad
15734 !-----------------------------------------------------------------------------
15735       subroutine zerograd
15736 !      implicit real*8 (a-h,o-z)
15737 !      include 'DIMENSIONS'
15738 !      include 'COMMON.DERIV'
15739 !      include 'COMMON.CHAIN'
15740 !      include 'COMMON.VAR'
15741 !      include 'COMMON.MD'
15742 !      include 'COMMON.SCCOR'
15743 !
15744 !el local variables
15745       integer :: i,j,intertyp,k
15746 ! Initialize Cartesian-coordinate gradient
15747 !
15748 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
15749 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
15750
15751 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
15752 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
15753 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
15754 !      allocate(gradcorr_long(3,nres))
15755 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
15756 !      allocate(gcorr6_turn_long(3,nres))
15757 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
15758
15759 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
15760
15761 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
15762 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
15763
15764 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
15765 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
15766
15767 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
15768 !      allocate(gscloc(3,nres)) !(3,maxres)
15769 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
15770
15771
15772
15773 !      common /deriv_scloc/
15774 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
15775 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
15776 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
15777 !      common /mpgrad/
15778 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
15779
15780
15781
15782 !          gradc(j,i,icg)=0.0d0
15783 !          gradx(j,i,icg)=0.0d0
15784
15785 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
15786 !elwrite(iout,*) "icg",icg
15787       do i=-1,nres
15788         do j=1,3
15789           gvdwx(j,i)=0.0D0
15790           gradx_scp(j,i)=0.0D0
15791           gvdwc(j,i)=0.0D0
15792           gvdwc_scp(j,i)=0.0D0
15793           gvdwc_scpp(j,i)=0.0d0
15794           gelc(j,i)=0.0D0
15795           gelc_long(j,i)=0.0D0
15796           gradb(j,i)=0.0d0
15797           gradbx(j,i)=0.0d0
15798           gvdwpp(j,i)=0.0d0
15799           gel_loc(j,i)=0.0d0
15800           gel_loc_long(j,i)=0.0d0
15801           ghpbc(j,i)=0.0D0
15802           ghpbx(j,i)=0.0D0
15803           gcorr3_turn(j,i)=0.0d0
15804           gcorr4_turn(j,i)=0.0d0
15805           gradcorr(j,i)=0.0d0
15806           gradcorr_long(j,i)=0.0d0
15807           gradcorr5_long(j,i)=0.0d0
15808           gradcorr6_long(j,i)=0.0d0
15809           gcorr6_turn_long(j,i)=0.0d0
15810           gradcorr5(j,i)=0.0d0
15811           gradcorr6(j,i)=0.0d0
15812           gcorr6_turn(j,i)=0.0d0
15813           gsccorc(j,i)=0.0d0
15814           gsccorx(j,i)=0.0d0
15815           gradc(j,i,icg)=0.0d0
15816           gradx(j,i,icg)=0.0d0
15817           gscloc(j,i)=0.0d0
15818           gsclocx(j,i)=0.0d0
15819           gliptran(j,i)=0.0d0
15820           gshieldx(j,i)=0.0d0
15821           gshieldc(j,i)=0.0d0
15822           gshieldc_loc(j,i)=0.0d0
15823           gshieldx_ec(j,i)=0.0d0
15824           gshieldc_ec(j,i)=0.0d0
15825           gshieldc_loc_ec(j,i)=0.0d0
15826           gshieldx_t3(j,i)=0.0d0
15827           gshieldc_t3(j,i)=0.0d0
15828           gshieldc_loc_t3(j,i)=0.0d0
15829           gshieldx_t4(j,i)=0.0d0
15830           gshieldc_t4(j,i)=0.0d0
15831           gshieldc_loc_t4(j,i)=0.0d0
15832           gshieldx_ll(j,i)=0.0d0
15833           gshieldc_ll(j,i)=0.0d0
15834           gshieldc_loc_ll(j,i)=0.0d0
15835
15836           do intertyp=1,3
15837            gloc_sc(intertyp,i,icg)=0.0d0
15838           enddo
15839         enddo
15840       enddo
15841       do i=1,nres
15842        do j=1,maxcontsshi
15843        shield_list(j,i)=0
15844         do k=1,3
15845 !C           print *,i,j,k
15846            grad_shield_side(k,j,i)=0.0d0
15847            grad_shield_loc(k,j,i)=0.0d0
15848          enddo
15849        enddo
15850        ishield_list(i)=0
15851       enddo
15852
15853 !
15854 ! Initialize the gradient of local energy terms.
15855 !
15856 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
15857 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
15858 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
15859 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
15860 !      allocate(gel_loc_turn3(nres))
15861 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
15862 !      allocate(gsccor_loc(nres))       !(maxres)
15863
15864       do i=1,4*nres
15865         gloc(i,icg)=0.0D0
15866       enddo
15867       do i=1,nres
15868         gel_loc_loc(i)=0.0d0
15869         gcorr_loc(i)=0.0d0
15870         g_corr5_loc(i)=0.0d0
15871         g_corr6_loc(i)=0.0d0
15872         gel_loc_turn3(i)=0.0d0
15873         gel_loc_turn4(i)=0.0d0
15874         gel_loc_turn6(i)=0.0d0
15875         gsccor_loc(i)=0.0d0
15876       enddo
15877 ! initialize gcart and gxcart
15878 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
15879       do i=0,nres
15880         do j=1,3
15881           gcart(j,i)=0.0d0
15882           gxcart(j,i)=0.0d0
15883         enddo
15884       enddo
15885       return
15886       end subroutine zerograd
15887 !-----------------------------------------------------------------------------
15888       real(kind=8) function fdum()
15889       fdum=0.0D0
15890       return
15891       end function fdum
15892 !-----------------------------------------------------------------------------
15893 ! intcartderiv.F
15894 !-----------------------------------------------------------------------------
15895       subroutine intcartderiv
15896 !      implicit real*8 (a-h,o-z)
15897 !      include 'DIMENSIONS'
15898 #ifdef MPI
15899       include 'mpif.h'
15900 #endif
15901 !      include 'COMMON.SETUP'
15902 !      include 'COMMON.CHAIN'
15903 !      include 'COMMON.VAR'
15904 !      include 'COMMON.GEO'
15905 !      include 'COMMON.INTERACT'
15906 !      include 'COMMON.DERIV'
15907 !      include 'COMMON.IOUNITS'
15908 !      include 'COMMON.LOCAL'
15909 !      include 'COMMON.SCCOR'
15910       real(kind=8) :: pi4,pi34
15911       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
15912       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
15913                     dcosomega,dsinomega !(3,3,maxres)
15914       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
15915
15916       integer :: i,j,k
15917       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
15918                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
15919                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
15920                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
15921       integer :: nres2
15922       nres2=2*nres
15923
15924 !el from module energy-------------
15925 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
15926 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
15927 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
15928
15929 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
15930 !el      allocate(dsintau(3,3,3,0:nres2))
15931 !el      allocate(dtauangle(3,3,3,0:nres2))
15932 !el      allocate(domicron(3,2,2,0:nres2))
15933 !el      allocate(dcosomicron(3,2,2,0:nres2))
15934
15935
15936
15937 #if defined(MPI) && defined(PARINTDER)
15938       if (nfgtasks.gt.1 .and. me.eq.king) &
15939         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
15940 #endif
15941       pi4 = 0.5d0*pipol
15942       pi34 = 3*pi4
15943
15944 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
15945 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
15946
15947 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
15948       do i=1,nres
15949         do j=1,3
15950           dtheta(j,1,i)=0.0d0
15951           dtheta(j,2,i)=0.0d0
15952           dphi(j,1,i)=0.0d0
15953           dphi(j,2,i)=0.0d0
15954           dphi(j,3,i)=0.0d0
15955         enddo
15956       enddo
15957 ! Derivatives of theta's
15958 #if defined(MPI) && defined(PARINTDER)
15959 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
15960       do i=max0(ithet_start-1,3),ithet_end
15961 #else
15962       do i=3,nres
15963 #endif
15964         cost=dcos(theta(i))
15965         sint=sqrt(1-cost*cost)
15966         do j=1,3
15967           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
15968           vbld(i-1)
15969           if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
15970           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
15971           vbld(i)
15972           if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
15973         enddo
15974       enddo
15975 #if defined(MPI) && defined(PARINTDER)
15976 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
15977       do i=max0(ithet_start-1,3),ithet_end
15978 #else
15979       do i=3,nres
15980 #endif
15981       if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then
15982         cost1=dcos(omicron(1,i))
15983         sint1=sqrt(1-cost1*cost1)
15984         cost2=dcos(omicron(2,i))
15985         sint2=sqrt(1-cost2*cost2)
15986        do j=1,3
15987 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
15988           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
15989           cost1*dc_norm(j,i-2))/ &
15990           vbld(i-1)
15991           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
15992           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
15993           +cost1*(dc_norm(j,i-1+nres)))/ &
15994           vbld(i-1+nres)
15995           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
15996 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
15997 !C Looks messy but better than if in loop
15998           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
15999           +cost2*dc_norm(j,i-1))/ &
16000           vbld(i)
16001           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16002           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16003            +cost2*(-dc_norm(j,i-1+nres)))/ &
16004           vbld(i-1+nres)
16005 !          write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
16006           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16007         enddo
16008        endif
16009       enddo
16010 !elwrite(iout,*) "after vbld write"
16011 ! Derivatives of phi:
16012 ! If phi is 0 or 180 degrees, then the formulas
16013 ! have to be derived by power series expansion of the
16014 ! conventional formulas around 0 and 180.
16015 #ifdef PARINTDER
16016       do i=iphi1_start,iphi1_end
16017 #else
16018       do i=4,nres
16019 #endif
16020 !        if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle
16021 ! the conventional case
16022         sint=dsin(theta(i))
16023         sint1=dsin(theta(i-1))
16024         sing=dsin(phi(i))
16025         cost=dcos(theta(i))
16026         cost1=dcos(theta(i-1))
16027         cosg=dcos(phi(i))
16028         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16029         fac0=1.0d0/(sint1*sint)
16030         fac1=cost*fac0
16031         fac2=cost1*fac0
16032         fac3=cosg*cost1/(sint1*sint1)
16033         fac4=cosg*cost/(sint*sint)
16034 !    Obtaining the gamma derivatives from sine derivative
16035        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16036            phi(i).gt.pi34.and.phi(i).le.pi.or. &
16037            phi(i).ge.-pi.and.phi(i).le.-pi34) then
16038          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16039          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16040          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16041          do j=1,3
16042             ctgt=cost/sint
16043             ctgt1=cost1/sint1
16044             cosg_inv=1.0d0/cosg
16045             if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
16046             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16047               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16048             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16049             dsinphi(j,2,i)= &
16050               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16051               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16052             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16053             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16054               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16055 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16056             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16057             endif
16058 ! Bug fixed 3/24/05 (AL)
16059          enddo
16060 !   Obtaining the gamma derivatives from cosine derivative
16061         else
16062            do j=1,3
16063            if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then
16064            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16065            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16066            dc_norm(j,i-3))/vbld(i-2)
16067            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16068            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16069            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16070            dcostheta(j,1,i)
16071            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16072            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16073            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16074            dc_norm(j,i-1))/vbld(i)
16075            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16076            endif
16077          enddo
16078         endif
16079       enddo
16080 !alculate derivative of Tauangle
16081 #ifdef PARINTDER
16082       do i=itau_start,itau_end
16083 #else
16084       do i=3,nres
16085 !elwrite(iout,*) " vecpr",i,nres
16086 #endif
16087        if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
16088 !       if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or.
16089 !     &     (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
16090 !c dtauangle(j,intertyp,dervityp,residue number)
16091 !c INTERTYP=1 SC...Ca...Ca..Ca
16092 ! the conventional case
16093         sint=dsin(theta(i))
16094         sint1=dsin(omicron(2,i-1))
16095         sing=dsin(tauangle(1,i))
16096         cost=dcos(theta(i))
16097         cost1=dcos(omicron(2,i-1))
16098         cosg=dcos(tauangle(1,i))
16099 !elwrite(iout,*) " vecpr5",i,nres
16100         do j=1,3
16101 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16102 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16103         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16104 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16105         enddo
16106         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16107         fac0=1.0d0/(sint1*sint)
16108         fac1=cost*fac0
16109         fac2=cost1*fac0
16110         fac3=cosg*cost1/(sint1*sint1)
16111         fac4=cosg*cost/(sint*sint)
16112 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16113 !    Obtaining the gamma derivatives from sine derivative
16114        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16115            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16116            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16117          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16118          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16119          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16120         do j=1,3
16121             ctgt=cost/sint
16122             ctgt1=cost1/sint1
16123             cosg_inv=1.0d0/cosg
16124             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16125        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16126        *vbld_inv(i-2+nres)
16127             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16128             dsintau(j,1,2,i)= &
16129               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16130               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16131 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16132             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16133 ! Bug fixed 3/24/05 (AL)
16134             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16135               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16136 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16137             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16138          enddo
16139 !   Obtaining the gamma derivatives from cosine derivative
16140         else
16141            do j=1,3
16142            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16143            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16144            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16145            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16146            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16147            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16148            dcostheta(j,1,i)
16149            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16150            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16151            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16152            dc_norm(j,i-1))/vbld(i)
16153            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16154 !         write (iout,*) "else",i
16155          enddo
16156         endif
16157 !        do k=1,3
16158 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16159 !        enddo
16160       enddo
16161 !C Second case Ca...Ca...Ca...SC
16162 #ifdef PARINTDER
16163       do i=itau_start,itau_end
16164 #else
16165       do i=4,nres
16166 #endif
16167        if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
16168           (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle
16169 ! the conventional case
16170         sint=dsin(omicron(1,i))
16171         sint1=dsin(theta(i-1))
16172         sing=dsin(tauangle(2,i))
16173         cost=dcos(omicron(1,i))
16174         cost1=dcos(theta(i-1))
16175         cosg=dcos(tauangle(2,i))
16176 !        do j=1,3
16177 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16178 !        enddo
16179         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16180         fac0=1.0d0/(sint1*sint)
16181         fac1=cost*fac0
16182         fac2=cost1*fac0
16183         fac3=cosg*cost1/(sint1*sint1)
16184         fac4=cosg*cost/(sint*sint)
16185 !    Obtaining the gamma derivatives from sine derivative
16186        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16187            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16188            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16189          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16190          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16191          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16192         do j=1,3
16193             ctgt=cost/sint
16194             ctgt1=cost1/sint1
16195             cosg_inv=1.0d0/cosg
16196             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16197               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16198 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16199 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16200             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16201             dsintau(j,2,2,i)= &
16202               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16203               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16204 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16205 !     & sing*ctgt*domicron(j,1,2,i),
16206 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16207             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16208 ! Bug fixed 3/24/05 (AL)
16209             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16210              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16211 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16212             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16213          enddo
16214 !   Obtaining the gamma derivatives from cosine derivative
16215         else
16216            do j=1,3
16217            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16218            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16219            dc_norm(j,i-3))/vbld(i-2)
16220            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16221            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16222            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16223            dcosomicron(j,1,1,i)
16224            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16225            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16226            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16227            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16228            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16229 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16230          enddo
16231         endif
16232       enddo
16233
16234 !CC third case SC...Ca...Ca...SC
16235 #ifdef PARINTDER
16236
16237       do i=itau_start,itau_end
16238 #else
16239       do i=3,nres
16240 #endif
16241 ! the conventional case
16242       if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. &
16243       (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle
16244         sint=dsin(omicron(1,i))
16245         sint1=dsin(omicron(2,i-1))
16246         sing=dsin(tauangle(3,i))
16247         cost=dcos(omicron(1,i))
16248         cost1=dcos(omicron(2,i-1))
16249         cosg=dcos(tauangle(3,i))
16250         do j=1,3
16251         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16252 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16253         enddo
16254         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16255         fac0=1.0d0/(sint1*sint)
16256         fac1=cost*fac0
16257         fac2=cost1*fac0
16258         fac3=cosg*cost1/(sint1*sint1)
16259         fac4=cosg*cost/(sint*sint)
16260 !    Obtaining the gamma derivatives from sine derivative
16261        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16262            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16263            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16264          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16265          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16266          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16267         do j=1,3
16268             ctgt=cost/sint
16269             ctgt1=cost1/sint1
16270             cosg_inv=1.0d0/cosg
16271             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16272               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16273               *vbld_inv(i-2+nres)
16274             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16275             dsintau(j,3,2,i)= &
16276               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16277               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16278             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16279 ! Bug fixed 3/24/05 (AL)
16280             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16281               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16282               *vbld_inv(i-1+nres)
16283 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16284             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16285          enddo
16286 !   Obtaining the gamma derivatives from cosine derivative
16287         else
16288            do j=1,3
16289            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16290            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16291            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16292            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16293            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16294            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16295            dcosomicron(j,1,1,i)
16296            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16297            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16298            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16299            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16300            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16301 !          write(iout,*) "else",i
16302          enddo
16303         endif
16304       enddo
16305
16306 #ifdef CRYST_SC
16307 !   Derivatives of side-chain angles alpha and omega
16308 #if defined(MPI) && defined(PARINTDER)
16309         do i=ibond_start,ibond_end
16310 #else
16311         do i=2,nres-1
16312 #endif
16313           if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then
16314              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16315              fac6=fac5/vbld(i)
16316              fac7=fac5*fac5
16317              fac8=fac5/vbld(i+1)
16318              fac9=fac5/vbld(i+nres)
16319              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16320              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16321              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16322              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16323              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16324              sina=sqrt(1-cosa*cosa)
16325              sino=dsin(omeg(i))
16326 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16327              do j=1,3
16328                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16329                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16330                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16331                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16332                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16333                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16334                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16335                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16336                 vbld(i+nres))
16337                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16338             enddo
16339 ! obtaining the derivatives of omega from sines
16340             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16341                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16342                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16343                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16344                dsin(theta(i+1)))
16345                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16346                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16347                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16348                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16349                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16350                coso_inv=1.0d0/dcos(omeg(i))
16351                do j=1,3
16352                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16353                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16354                  (sino*dc_norm(j,i-1))/vbld(i)
16355                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16356                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16357                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16358                  -sino*dc_norm(j,i)/vbld(i+1)
16359                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16360                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16361                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16362                  vbld(i+nres)
16363                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16364               enddo
16365            else
16366 !   obtaining the derivatives of omega from cosines
16367              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16368              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16369              fac12=fac10*sina
16370              fac13=fac12*fac12
16371              fac14=sina*sina
16372              do j=1,3
16373                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16374                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16375                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16376                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16377                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
16378                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
16379                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
16380                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
16381                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
16382                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
16383                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
16384                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
16385                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
16386                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
16387                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
16388             enddo
16389           endif
16390          else
16391            do j=1,3
16392              do k=1,3
16393                dalpha(k,j,i)=0.0d0
16394                domega(k,j,i)=0.0d0
16395              enddo
16396            enddo
16397          endif
16398        enddo
16399 #endif
16400 #if defined(MPI) && defined(PARINTDER)
16401       if (nfgtasks.gt.1) then
16402 #ifdef DEBUG
16403 !d      write (iout,*) "Gather dtheta"
16404 !d      call flush(iout)
16405       write (iout,*) "dtheta before gather"
16406       do i=1,nres
16407         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
16408       enddo
16409 #endif
16410       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
16411         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
16412         king,FG_COMM,IERROR)
16413 #ifdef DEBUG
16414 !d      write (iout,*) "Gather dphi"
16415 !d      call flush(iout)
16416       write (iout,*) "dphi before gather"
16417       do i=1,nres
16418         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
16419       enddo
16420 #endif
16421       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
16422         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
16423         king,FG_COMM,IERROR)
16424 !d      write (iout,*) "Gather dalpha"
16425 !d      call flush(iout)
16426 #ifdef CRYST_SC
16427       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
16428         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16429         king,FG_COMM,IERROR)
16430 !d      write (iout,*) "Gather domega"
16431 !d      call flush(iout)
16432       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
16433         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16434         king,FG_COMM,IERROR)
16435 #endif
16436       endif
16437 #endif
16438 #ifdef DEBUG
16439       write (iout,*) "dtheta after gather"
16440       do i=1,nres
16441         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
16442       enddo
16443       write (iout,*) "dphi after gather"
16444       do i=1,nres
16445         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
16446       enddo
16447       write (iout,*) "dalpha after gather"
16448       do i=1,nres
16449         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
16450       enddo
16451       write (iout,*) "domega after gather"
16452       do i=1,nres
16453         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
16454       enddo
16455 #endif
16456       return
16457       end subroutine intcartderiv
16458 !-----------------------------------------------------------------------------
16459       subroutine checkintcartgrad
16460 !      implicit real*8 (a-h,o-z)
16461 !      include 'DIMENSIONS'
16462 #ifdef MPI
16463       include 'mpif.h'
16464 #endif
16465 !      include 'COMMON.CHAIN'
16466 !      include 'COMMON.VAR'
16467 !      include 'COMMON.GEO'
16468 !      include 'COMMON.INTERACT'
16469 !      include 'COMMON.DERIV'
16470 !      include 'COMMON.IOUNITS'
16471 !      include 'COMMON.SETUP'
16472       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
16473       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
16474       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
16475       real(kind=8),dimension(3) :: dc_norm_s
16476       real(kind=8) :: aincr=1.0d-5
16477       integer :: i,j
16478       real(kind=8) :: dcji
16479       do i=1,nres
16480         phi_s(i)=phi(i)
16481         theta_s(i)=theta(i)
16482         alph_s(i)=alph(i)
16483         omeg_s(i)=omeg(i)
16484       enddo
16485 ! Check theta gradient
16486       write (iout,*) &
16487        "Analytical (upper) and numerical (lower) gradient of theta"
16488       write (iout,*)
16489       do i=3,nres
16490         do j=1,3
16491           dcji=dc(j,i-2)
16492           dc(j,i-2)=dcji+aincr
16493           call chainbuild_cart
16494           call int_from_cart1(.false.)
16495           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
16496           dc(j,i-2)=dcji
16497           dcji=dc(j,i-1)
16498           dc(j,i-1)=dc(j,i-1)+aincr
16499           call chainbuild_cart
16500           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
16501           dc(j,i-1)=dcji
16502         enddo
16503 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
16504 !el          (dtheta(j,2,i),j=1,3)
16505 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
16506 !el          (dthetanum(j,2,i),j=1,3)
16507 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
16508 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
16509 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
16510 !el        write (iout,*)
16511       enddo
16512 ! Check gamma gradient
16513       write (iout,*) &
16514        "Analytical (upper) and numerical (lower) gradient of gamma"
16515       do i=4,nres
16516         do j=1,3
16517           dcji=dc(j,i-3)
16518           dc(j,i-3)=dcji+aincr
16519           call chainbuild_cart
16520           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
16521           dc(j,i-3)=dcji
16522           dcji=dc(j,i-2)
16523           dc(j,i-2)=dcji+aincr
16524           call chainbuild_cart
16525           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
16526           dc(j,i-2)=dcji
16527           dcji=dc(j,i-1)
16528           dc(j,i-1)=dc(j,i-1)+aincr
16529           call chainbuild_cart
16530           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
16531           dc(j,i-1)=dcji
16532         enddo
16533 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
16534 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
16535 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
16536 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
16537 !el        write (iout,'(5x,3(3f10.5,5x))') &
16538 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
16539 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
16540 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
16541 !el        write (iout,*)
16542       enddo
16543 ! Check alpha gradient
16544       write (iout,*) &
16545        "Analytical (upper) and numerical (lower) gradient of alpha"
16546       do i=2,nres-1
16547        if(itype(i).ne.10) then
16548             do j=1,3
16549               dcji=dc(j,i-1)
16550               dc(j,i-1)=dcji+aincr
16551               call chainbuild_cart
16552               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
16553               /aincr
16554               dc(j,i-1)=dcji
16555               dcji=dc(j,i)
16556               dc(j,i)=dcji+aincr
16557               call chainbuild_cart
16558               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
16559               /aincr
16560               dc(j,i)=dcji
16561               dcji=dc(j,i+nres)
16562               dc(j,i+nres)=dc(j,i+nres)+aincr
16563               call chainbuild_cart
16564               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
16565               /aincr
16566              dc(j,i+nres)=dcji
16567             enddo
16568           endif
16569 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
16570 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
16571 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
16572 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
16573 !el        write (iout,'(5x,3(3f10.5,5x))') &
16574 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
16575 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
16576 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
16577 !el        write (iout,*)
16578       enddo
16579 !     Check omega gradient
16580       write (iout,*) &
16581        "Analytical (upper) and numerical (lower) gradient of omega"
16582       do i=2,nres-1
16583        if(itype(i).ne.10) then
16584             do j=1,3
16585               dcji=dc(j,i-1)
16586               dc(j,i-1)=dcji+aincr
16587               call chainbuild_cart
16588               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
16589               /aincr
16590               dc(j,i-1)=dcji
16591               dcji=dc(j,i)
16592               dc(j,i)=dcji+aincr
16593               call chainbuild_cart
16594               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
16595               /aincr
16596               dc(j,i)=dcji
16597               dcji=dc(j,i+nres)
16598               dc(j,i+nres)=dc(j,i+nres)+aincr
16599               call chainbuild_cart
16600               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
16601               /aincr
16602              dc(j,i+nres)=dcji
16603             enddo
16604           endif
16605 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
16606 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
16607 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
16608 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
16609 !el        write (iout,'(5x,3(3f10.5,5x))') &
16610 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
16611 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
16612 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
16613 !el        write (iout,*)
16614       enddo
16615       return
16616       end subroutine checkintcartgrad
16617 !-----------------------------------------------------------------------------
16618 ! q_measure.F
16619 !-----------------------------------------------------------------------------
16620       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
16621 !      implicit real*8 (a-h,o-z)
16622 !      include 'DIMENSIONS'
16623 !      include 'COMMON.IOUNITS'
16624 !      include 'COMMON.CHAIN'
16625 !      include 'COMMON.INTERACT'
16626 !      include 'COMMON.VAR'
16627       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
16628       integer :: kkk,nsep=3
16629       real(kind=8) :: qm        !dist,
16630       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
16631       logical :: lprn=.false.
16632       logical :: flag
16633 !      real(kind=8) :: sigm,x
16634
16635 !el      sigm(x)=0.25d0*x     ! local function
16636       qqmax=1.0d10
16637       do kkk=1,nperm
16638       qq = 0.0d0
16639       nl=0
16640        if(flag) then
16641         do il=seg1+nsep,seg2
16642           do jl=seg1,il-nsep
16643             nl=nl+1
16644             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
16645                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
16646                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16647             dij=dist(il,jl)
16648             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
16649             if (itype(il).ne.10 .or. itype(jl).ne.10) then
16650               nl=nl+1
16651               d0ijCM=dsqrt( &
16652                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16653                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16654                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16655               dijCM=dist(il+nres,jl+nres)
16656               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
16657             endif
16658             qq = qq+qqij+qqijCM
16659           enddo
16660         enddo
16661         qq = qq/nl
16662       else
16663       do il=seg1,seg2
16664         if((seg3-il).lt.3) then
16665              secseg=il+3
16666         else
16667              secseg=seg3
16668         endif
16669           do jl=secseg,seg4
16670             nl=nl+1
16671             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16672                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16673                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16674             dij=dist(il,jl)
16675             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
16676             if (itype(il).ne.10 .or. itype(jl).ne.10) then
16677               nl=nl+1
16678               d0ijCM=dsqrt( &
16679                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16680                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16681                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16682               dijCM=dist(il+nres,jl+nres)
16683               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
16684             endif
16685             qq = qq+qqij+qqijCM
16686           enddo
16687         enddo
16688       qq = qq/nl
16689       endif
16690       if (qqmax.le.qq) qqmax=qq
16691       enddo
16692       qwolynes=1.0d0-qqmax
16693       return
16694       end function qwolynes
16695 !-----------------------------------------------------------------------------
16696       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
16697 !      implicit real*8 (a-h,o-z)
16698 !      include 'DIMENSIONS'
16699 !      include 'COMMON.IOUNITS'
16700 !      include 'COMMON.CHAIN'
16701 !      include 'COMMON.INTERACT'
16702 !      include 'COMMON.VAR'
16703 !      include 'COMMON.MD'
16704       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
16705       integer :: nsep=3, kkk
16706 !el      real(kind=8) :: dist
16707       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
16708       logical :: lprn=.false.
16709       logical :: flag
16710       real(kind=8) :: sim,dd0,fac,ddqij
16711 !el      sigm(x)=0.25d0*x            ! local function
16712       do kkk=1,nperm
16713       do i=0,nres
16714         do j=1,3
16715           dqwol(j,i)=0.0d0
16716           dxqwol(j,i)=0.0d0
16717         enddo
16718       enddo
16719       nl=0
16720        if(flag) then
16721         do il=seg1+nsep,seg2
16722           do jl=seg1,il-nsep
16723             nl=nl+1
16724             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16725                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16726                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16727             dij=dist(il,jl)
16728             sim = 1.0d0/sigm(d0ij)
16729             sim = sim*sim
16730             dd0 = dij-d0ij
16731             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
16732             do k=1,3
16733               ddqij = (c(k,il)-c(k,jl))*fac
16734               dqwol(k,il)=dqwol(k,il)+ddqij
16735               dqwol(k,jl)=dqwol(k,jl)-ddqij
16736             enddo
16737
16738             if (itype(il).ne.10 .or. itype(jl).ne.10) then
16739               nl=nl+1
16740               d0ijCM=dsqrt( &
16741                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16742                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16743                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16744               dijCM=dist(il+nres,jl+nres)
16745               sim = 1.0d0/sigm(d0ijCM)
16746               sim = sim*sim
16747               dd0=dijCM-d0ijCM
16748               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
16749               do k=1,3
16750                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
16751                 dxqwol(k,il)=dxqwol(k,il)+ddqij
16752                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
16753               enddo
16754             endif
16755           enddo
16756         enddo
16757        else
16758         do il=seg1,seg2
16759         if((seg3-il).lt.3) then
16760              secseg=il+3
16761         else
16762              secseg=seg3
16763         endif
16764           do jl=secseg,seg4
16765             nl=nl+1
16766             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
16767                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
16768                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
16769             dij=dist(il,jl)
16770             sim = 1.0d0/sigm(d0ij)
16771             sim = sim*sim
16772             dd0 = dij-d0ij
16773             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
16774             do k=1,3
16775               ddqij = (c(k,il)-c(k,jl))*fac
16776               dqwol(k,il)=dqwol(k,il)+ddqij
16777               dqwol(k,jl)=dqwol(k,jl)-ddqij
16778             enddo
16779             if (itype(il).ne.10 .or. itype(jl).ne.10) then
16780               nl=nl+1
16781               d0ijCM=dsqrt( &
16782                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
16783                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
16784                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
16785               dijCM=dist(il+nres,jl+nres)
16786               sim = 1.0d0/sigm(d0ijCM)
16787               sim=sim*sim
16788               dd0 = dijCM-d0ijCM
16789               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
16790               do k=1,3
16791                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
16792                dxqwol(k,il)=dxqwol(k,il)+ddqij
16793                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
16794               enddo
16795             endif
16796           enddo
16797         enddo
16798       endif
16799       enddo
16800        do i=0,nres
16801          do j=1,3
16802            dqwol(j,i)=dqwol(j,i)/nl
16803            dxqwol(j,i)=dxqwol(j,i)/nl
16804          enddo
16805        enddo
16806       return
16807       end subroutine qwolynes_prim
16808 !-----------------------------------------------------------------------------
16809       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
16810 !      implicit real*8 (a-h,o-z)
16811 !      include 'DIMENSIONS'
16812 !      include 'COMMON.IOUNITS'
16813 !      include 'COMMON.CHAIN'
16814 !      include 'COMMON.INTERACT'
16815 !      include 'COMMON.VAR'
16816       integer :: seg1,seg2,seg3,seg4
16817       logical :: flag
16818       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
16819       real(kind=8),dimension(3,0:2*nres) :: cdummy
16820       real(kind=8) :: q1,q2
16821       real(kind=8) :: delta=1.0d-10
16822       integer :: i,j
16823
16824       do i=0,nres
16825         do j=1,3
16826           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
16827           cdummy(j,i)=c(j,i)
16828           c(j,i)=c(j,i)+delta
16829           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
16830           qwolan(j,i)=(q2-q1)/delta
16831           c(j,i)=cdummy(j,i)
16832         enddo
16833       enddo
16834       do i=0,nres
16835         do j=1,3
16836           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
16837           cdummy(j,i+nres)=c(j,i+nres)
16838           c(j,i+nres)=c(j,i+nres)+delta
16839           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
16840           qwolxan(j,i)=(q2-q1)/delta
16841           c(j,i+nres)=cdummy(j,i+nres)
16842         enddo
16843       enddo
16844 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
16845 !      do i=0,nct
16846 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
16847 !      enddo
16848 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
16849 !      do i=0,nct
16850 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
16851 !      enddo
16852       return
16853       end subroutine qwol_num
16854 !-----------------------------------------------------------------------------
16855       subroutine EconstrQ
16856 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
16857 !      implicit real*8 (a-h,o-z)
16858 !      include 'DIMENSIONS'
16859 !      include 'COMMON.CONTROL'
16860 !      include 'COMMON.VAR'
16861 !      include 'COMMON.MD'
16862       use MD_data
16863 !#ifndef LANG0
16864 !      include 'COMMON.LANGEVIN'
16865 !#else
16866 !      include 'COMMON.LANGEVIN.lang0'
16867 !#endif
16868 !      include 'COMMON.CHAIN'
16869 !      include 'COMMON.DERIV'
16870 !      include 'COMMON.GEO'
16871 !      include 'COMMON.LOCAL'
16872 !      include 'COMMON.INTERACT'
16873 !      include 'COMMON.IOUNITS'
16874 !      include 'COMMON.NAMES'
16875 !      include 'COMMON.TIME1'
16876       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
16877       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
16878                    duconst,duxconst
16879       integer :: kstart,kend,lstart,lend,idummy
16880       real(kind=8) :: delta=1.0d-7
16881       integer :: i,j,k,ii
16882       do i=0,nres
16883          do j=1,3
16884             duconst(j,i)=0.0d0
16885             dudconst(j,i)=0.0d0
16886             duxconst(j,i)=0.0d0
16887             dudxconst(j,i)=0.0d0
16888          enddo
16889       enddo
16890       Uconst=0.0d0
16891       do i=1,nfrag
16892          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
16893            idummy,idummy)
16894          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
16895 ! Calculating the derivatives of Constraint energy with respect to Q
16896          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
16897            qinfrag(i,iset))
16898 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
16899 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
16900 !         hmnum=(hm2-hm1)/delta
16901 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
16902 !     &   qinfrag(i,iset))
16903 !         write(iout,*) "harmonicnum frag", hmnum
16904 ! Calculating the derivatives of Q with respect to cartesian coordinates
16905          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
16906           idummy,idummy)
16907 !         write(iout,*) "dqwol "
16908 !         do ii=1,nres
16909 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
16910 !         enddo
16911 !         write(iout,*) "dxqwol "
16912 !         do ii=1,nres
16913 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
16914 !         enddo
16915 ! Calculating numerical gradients of dU/dQi and dQi/dxi
16916 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
16917 !     &  ,idummy,idummy)
16918 !  The gradients of Uconst in Cs
16919          do ii=0,nres
16920             do j=1,3
16921                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
16922                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
16923             enddo
16924          enddo
16925       enddo
16926       do i=1,npair
16927          kstart=ifrag(1,ipair(1,i,iset),iset)
16928          kend=ifrag(2,ipair(1,i,iset),iset)
16929          lstart=ifrag(1,ipair(2,i,iset),iset)
16930          lend=ifrag(2,ipair(2,i,iset),iset)
16931          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
16932          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
16933 !  Calculating dU/dQ
16934          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
16935 !         hm1=harmonic(qpair(i),qinpair(i,iset))
16936 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
16937 !         hmnum=(hm2-hm1)/delta
16938 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
16939 !     &   qinpair(i,iset))
16940 !         write(iout,*) "harmonicnum pair ", hmnum
16941 ! Calculating dQ/dXi
16942          call qwolynes_prim(kstart,kend,.false.,&
16943           lstart,lend)
16944 !         write(iout,*) "dqwol "
16945 !         do ii=1,nres
16946 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
16947 !         enddo
16948 !         write(iout,*) "dxqwol "
16949 !         do ii=1,nres
16950 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
16951 !        enddo
16952 ! Calculating numerical gradients
16953 !        call qwol_num(kstart,kend,.false.
16954 !     &  ,lstart,lend)
16955 ! The gradients of Uconst in Cs
16956          do ii=0,nres
16957             do j=1,3
16958                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
16959                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
16960             enddo
16961          enddo
16962       enddo
16963 !      write(iout,*) "Uconst inside subroutine ", Uconst
16964 ! Transforming the gradients from Cs to dCs for the backbone
16965       do i=0,nres
16966          do j=i+1,nres
16967            do k=1,3
16968              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
16969            enddo
16970          enddo
16971       enddo
16972 !  Transforming the gradients from Cs to dCs for the side chains
16973       do i=1,nres
16974          do j=1,3
16975            dudxconst(j,i)=duxconst(j,i)
16976          enddo
16977       enddo
16978 !      write(iout,*) "dU/ddc backbone "
16979 !       do ii=0,nres
16980 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
16981 !      enddo
16982 !      write(iout,*) "dU/ddX side chain "
16983 !      do ii=1,nres
16984 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
16985 !      enddo
16986 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
16987 !      call dEconstrQ_num
16988       return
16989       end subroutine EconstrQ
16990 !-----------------------------------------------------------------------------
16991       subroutine dEconstrQ_num
16992 ! Calculating numerical dUconst/ddc and dUconst/ddx
16993 !      implicit real*8 (a-h,o-z)
16994 !      include 'DIMENSIONS'
16995 !      include 'COMMON.CONTROL'
16996 !      include 'COMMON.VAR'
16997 !      include 'COMMON.MD'
16998       use MD_data
16999 !#ifndef LANG0
17000 !      include 'COMMON.LANGEVIN'
17001 !#else
17002 !      include 'COMMON.LANGEVIN.lang0'
17003 !#endif
17004 !      include 'COMMON.CHAIN'
17005 !      include 'COMMON.DERIV'
17006 !      include 'COMMON.GEO'
17007 !      include 'COMMON.LOCAL'
17008 !      include 'COMMON.INTERACT'
17009 !      include 'COMMON.IOUNITS'
17010 !      include 'COMMON.NAMES'
17011 !      include 'COMMON.TIME1'
17012       real(kind=8) :: uzap1,uzap2
17013       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17014       integer :: kstart,kend,lstart,lend,idummy
17015       real(kind=8) :: delta=1.0d-7
17016 !el local variables
17017       integer :: i,ii,j
17018 !     real(kind=8) ::
17019 !     For the backbone
17020       do i=0,nres-1
17021          do j=1,3
17022             dUcartan(j,i)=0.0d0
17023             cdummy(j,i)=dc(j,i)
17024             dc(j,i)=dc(j,i)+delta
17025             call chainbuild_cart
17026             uzap2=0.0d0
17027             do ii=1,nfrag
17028              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17029                 idummy,idummy)
17030                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17031                 qinfrag(ii,iset))
17032             enddo
17033             do ii=1,npair
17034                kstart=ifrag(1,ipair(1,ii,iset),iset)
17035                kend=ifrag(2,ipair(1,ii,iset),iset)
17036                lstart=ifrag(1,ipair(2,ii,iset),iset)
17037                lend=ifrag(2,ipair(2,ii,iset),iset)
17038                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17039                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17040                  qinpair(ii,iset))
17041             enddo
17042             dc(j,i)=cdummy(j,i)
17043             call chainbuild_cart
17044             uzap1=0.0d0
17045              do ii=1,nfrag
17046              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17047                 idummy,idummy)
17048                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17049                 qinfrag(ii,iset))
17050             enddo
17051             do ii=1,npair
17052                kstart=ifrag(1,ipair(1,ii,iset),iset)
17053                kend=ifrag(2,ipair(1,ii,iset),iset)
17054                lstart=ifrag(1,ipair(2,ii,iset),iset)
17055                lend=ifrag(2,ipair(2,ii,iset),iset)
17056                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17057                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17058                 qinpair(ii,iset))
17059             enddo
17060             ducartan(j,i)=(uzap2-uzap1)/(delta)
17061          enddo
17062       enddo
17063 ! Calculating numerical gradients for dU/ddx
17064       do i=0,nres-1
17065          duxcartan(j,i)=0.0d0
17066          do j=1,3
17067             cdummy(j,i)=dc(j,i+nres)
17068             dc(j,i+nres)=dc(j,i+nres)+delta
17069             call chainbuild_cart
17070             uzap2=0.0d0
17071             do ii=1,nfrag
17072              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17073                 idummy,idummy)
17074                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17075                 qinfrag(ii,iset))
17076             enddo
17077             do ii=1,npair
17078                kstart=ifrag(1,ipair(1,ii,iset),iset)
17079                kend=ifrag(2,ipair(1,ii,iset),iset)
17080                lstart=ifrag(1,ipair(2,ii,iset),iset)
17081                lend=ifrag(2,ipair(2,ii,iset),iset)
17082                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17083                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17084                 qinpair(ii,iset))
17085             enddo
17086             dc(j,i+nres)=cdummy(j,i)
17087             call chainbuild_cart
17088             uzap1=0.0d0
17089              do ii=1,nfrag
17090                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17091                 ifrag(2,ii,iset),.true.,idummy,idummy)
17092                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17093                 qinfrag(ii,iset))
17094             enddo
17095             do ii=1,npair
17096                kstart=ifrag(1,ipair(1,ii,iset),iset)
17097                kend=ifrag(2,ipair(1,ii,iset),iset)
17098                lstart=ifrag(1,ipair(2,ii,iset),iset)
17099                lend=ifrag(2,ipair(2,ii,iset),iset)
17100                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17101                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17102                 qinpair(ii,iset))
17103             enddo
17104             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17105          enddo
17106       enddo
17107       write(iout,*) "Numerical dUconst/ddc backbone "
17108       do ii=0,nres
17109         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17110       enddo
17111 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17112 !      do ii=1,nres
17113 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17114 !      enddo
17115       return
17116       end subroutine dEconstrQ_num
17117 !-----------------------------------------------------------------------------
17118 ! ssMD.F
17119 !-----------------------------------------------------------------------------
17120       subroutine check_energies
17121
17122 !      use random, only: ran_number
17123
17124 !      implicit none
17125 !     Includes
17126 !      include 'DIMENSIONS'
17127 !      include 'COMMON.CHAIN'
17128 !      include 'COMMON.VAR'
17129 !      include 'COMMON.IOUNITS'
17130 !      include 'COMMON.SBRIDGE'
17131 !      include 'COMMON.LOCAL'
17132 !      include 'COMMON.GEO'
17133
17134 !     External functions
17135 !EL      double precision ran_number
17136 !EL      external ran_number
17137
17138 !     Local variables
17139       integer :: i,j,k,l,lmax,p,pmax
17140       real(kind=8) :: rmin,rmax
17141       real(kind=8) :: eij
17142
17143       real(kind=8) :: d
17144       real(kind=8) :: wi,rij,tj,pj
17145 !      return
17146
17147       i=5
17148       j=14
17149
17150       d=dsc(1)
17151       rmin=2.0D0
17152       rmax=12.0D0
17153
17154       lmax=10000
17155       pmax=1
17156
17157       do k=1,3
17158         c(k,i)=0.0D0
17159         c(k,j)=0.0D0
17160         c(k,nres+i)=0.0D0
17161         c(k,nres+j)=0.0D0
17162       enddo
17163
17164       do l=1,lmax
17165
17166 !t        wi=ran_number(0.0D0,pi)
17167 !        wi=ran_number(0.0D0,pi/6.0D0)
17168 !        wi=0.0D0
17169 !t        tj=ran_number(0.0D0,pi)
17170 !t        pj=ran_number(0.0D0,pi)
17171 !        pj=ran_number(0.0D0,pi/6.0D0)
17172 !        pj=0.0D0
17173
17174         do p=1,pmax
17175 !t           rij=ran_number(rmin,rmax)
17176
17177            c(1,j)=d*sin(pj)*cos(tj)
17178            c(2,j)=d*sin(pj)*sin(tj)
17179            c(3,j)=d*cos(pj)
17180
17181            c(3,nres+i)=-rij
17182
17183            c(1,i)=d*sin(wi)
17184            c(3,i)=-rij-d*cos(wi)
17185
17186            do k=1,3
17187               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17188               dc_norm(k,nres+i)=dc(k,nres+i)/d
17189               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17190               dc_norm(k,nres+j)=dc(k,nres+j)/d
17191            enddo
17192
17193            call dyn_ssbond_ene(i,j,eij)
17194         enddo
17195       enddo
17196       call exit(1)
17197       return
17198       end subroutine check_energies
17199 !-----------------------------------------------------------------------------
17200       subroutine dyn_ssbond_ene(resi,resj,eij)
17201 !      implicit none
17202 !      Includes
17203       use calc_data
17204       use comm_sschecks
17205 !      include 'DIMENSIONS'
17206 !      include 'COMMON.SBRIDGE'
17207 !      include 'COMMON.CHAIN'
17208 !      include 'COMMON.DERIV'
17209 !      include 'COMMON.LOCAL'
17210 !      include 'COMMON.INTERACT'
17211 !      include 'COMMON.VAR'
17212 !      include 'COMMON.IOUNITS'
17213 !      include 'COMMON.CALC'
17214 #ifndef CLUST
17215 #ifndef WHAM
17216        use MD_data
17217 !      include 'COMMON.MD'
17218 !      use MD, only: totT,t_bath
17219 #endif
17220 #endif
17221 !     External functions
17222 !EL      double precision h_base
17223 !EL      external h_base
17224
17225 !     Input arguments
17226       integer :: resi,resj
17227
17228 !     Output arguments
17229       real(kind=8) :: eij
17230
17231 !     Local variables
17232       logical :: havebond
17233       integer itypi,itypj
17234       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17235       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17236       real(kind=8),dimension(3) :: dcosom1,dcosom2
17237       real(kind=8) :: ed
17238       real(kind=8) :: pom1,pom2
17239       real(kind=8) :: ljA,ljB,ljXs
17240       real(kind=8),dimension(1:3) :: d_ljB
17241       real(kind=8) :: ssA,ssB,ssC,ssXs
17242       real(kind=8) :: ssxm,ljxm,ssm,ljm
17243       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17244       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17245       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17246 !-------FIRST METHOD
17247       real(kind=8) :: xm
17248       real(kind=8),dimension(1:3) :: d_xm
17249 !-------END FIRST METHOD
17250 !-------SECOND METHOD
17251 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17252 !-------END SECOND METHOD
17253
17254 !-------TESTING CODE
17255 !el      logical :: checkstop,transgrad
17256 !el      common /sschecks/ checkstop,transgrad
17257
17258       integer :: icheck,nicheck,jcheck,njcheck
17259       real(kind=8),dimension(-1:1) :: echeck
17260       real(kind=8) :: deps,ssx0,ljx0
17261 !-------END TESTING CODE
17262
17263       eij=0.0d0
17264       i=resi
17265       j=resj
17266
17267 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17268 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17269
17270       itypi=itype(i)
17271       dxi=dc_norm(1,nres+i)
17272       dyi=dc_norm(2,nres+i)
17273       dzi=dc_norm(3,nres+i)
17274       dsci_inv=vbld_inv(i+nres)
17275
17276       itypj=itype(j)
17277       xj=c(1,nres+j)-c(1,nres+i)
17278       yj=c(2,nres+j)-c(2,nres+i)
17279       zj=c(3,nres+j)-c(3,nres+i)
17280       dxj=dc_norm(1,nres+j)
17281       dyj=dc_norm(2,nres+j)
17282       dzj=dc_norm(3,nres+j)
17283       dscj_inv=vbld_inv(j+nres)
17284
17285       chi1=chi(itypi,itypj)
17286       chi2=chi(itypj,itypi)
17287       chi12=chi1*chi2
17288       chip1=chip(itypi)
17289       chip2=chip(itypj)
17290       chip12=chip1*chip2
17291       alf1=alp(itypi)
17292       alf2=alp(itypj)
17293       alf12=0.5D0*(alf1+alf2)
17294
17295       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17296       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17297 !     The following are set in sc_angular
17298 !      erij(1)=xj*rij
17299 !      erij(2)=yj*rij
17300 !      erij(3)=zj*rij
17301 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17302 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17303 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17304       call sc_angular
17305       rij=1.0D0/rij  ! Reset this so it makes sense
17306
17307       sig0ij=sigma(itypi,itypj)
17308       sig=sig0ij*dsqrt(1.0D0/sigsq)
17309
17310       ljXs=sig-sig0ij
17311       ljA=eps1*eps2rt**2*eps3rt**2
17312       ljB=ljA*bb_aq(itypi,itypj)
17313       ljA=ljA*aa_aq(itypi,itypj)
17314       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17315
17316       ssXs=d0cm
17317       deltat1=1.0d0-om1
17318       deltat2=1.0d0+om2
17319       deltat12=om2-om1+2.0d0
17320       cosphi=om12-om1*om2
17321       ssA=akcm
17322       ssB=akct*deltat12
17323       ssC=ss_depth &
17324            +akth*(deltat1*deltat1+deltat2*deltat2) &
17325            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17326       ssxm=ssXs-0.5D0*ssB/ssA
17327
17328 !-------TESTING CODE
17329 !$$$c     Some extra output
17330 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17331 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17332 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17333 !$$$      if (ssx0.gt.0.0d0) then
17334 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17335 !$$$      else
17336 !$$$        ssx0=ssxm
17337 !$$$      endif
17338 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17339 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17340 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17341 !$$$      return
17342 !-------END TESTING CODE
17343
17344 !-------TESTING CODE
17345 !     Stop and plot energy and derivative as a function of distance
17346       if (checkstop) then
17347         ssm=ssC-0.25D0*ssB*ssB/ssA
17348         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17349         if (ssm.lt.ljm .and. &
17350              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17351           nicheck=1000
17352           njcheck=1
17353           deps=0.5d-7
17354         else
17355           checkstop=.false.
17356         endif
17357       endif
17358       if (.not.checkstop) then
17359         nicheck=0
17360         njcheck=-1
17361       endif
17362
17363       do icheck=0,nicheck
17364       do jcheck=-1,njcheck
17365       if (checkstop) rij=(ssxm-1.0d0)+ &
17366              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17367 !-------END TESTING CODE
17368
17369       if (rij.gt.ljxm) then
17370         havebond=.false.
17371         ljd=rij-ljXs
17372         fac=(1.0D0/ljd)**expon
17373         e1=fac*fac*aa_aq(itypi,itypj)
17374         e2=fac*bb_aq(itypi,itypj)
17375         eij=eps1*eps2rt*eps3rt*(e1+e2)
17376         eps2der=eij*eps3rt
17377         eps3der=eij*eps2rt
17378         eij=eij*eps2rt*eps3rt
17379
17380         sigder=-sig/sigsq
17381         e1=e1*eps1*eps2rt**2*eps3rt**2
17382         ed=-expon*(e1+eij)/ljd
17383         sigder=ed*sigder
17384         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17385         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17386         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
17387              -2.0D0*alf12*eps3der+sigder*sigsq_om12
17388       else if (rij.lt.ssxm) then
17389         havebond=.true.
17390         ssd=rij-ssXs
17391         eij=ssA*ssd*ssd+ssB*ssd+ssC
17392
17393         ed=2*akcm*ssd+akct*deltat12
17394         pom1=akct*ssd
17395         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
17396         eom1=-2*akth*deltat1-pom1-om2*pom2
17397         eom2= 2*akth*deltat2+pom1-om1*pom2
17398         eom12=pom2
17399       else
17400         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
17401
17402         d_ssxm(1)=0.5D0*akct/ssA
17403         d_ssxm(2)=-d_ssxm(1)
17404         d_ssxm(3)=0.0D0
17405
17406         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
17407         d_ljxm(2)=d_ljxm(1)*sigsq_om2
17408         d_ljxm(3)=d_ljxm(1)*sigsq_om12
17409         d_ljxm(1)=d_ljxm(1)*sigsq_om1
17410
17411 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17412         xm=0.5d0*(ssxm+ljxm)
17413         do k=1,3
17414           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
17415         enddo
17416         if (rij.lt.xm) then
17417           havebond=.true.
17418           ssm=ssC-0.25D0*ssB*ssB/ssA
17419           d_ssm(1)=0.5D0*akct*ssB/ssA
17420           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17421           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17422           d_ssm(3)=omega
17423           f1=(rij-xm)/(ssxm-xm)
17424           f2=(rij-ssxm)/(xm-ssxm)
17425           h1=h_base(f1,hd1)
17426           h2=h_base(f2,hd2)
17427           eij=ssm*h1+Ht*h2
17428           delta_inv=1.0d0/(xm-ssxm)
17429           deltasq_inv=delta_inv*delta_inv
17430           fac=ssm*hd1-Ht*hd2
17431           fac1=deltasq_inv*fac*(xm-rij)
17432           fac2=deltasq_inv*fac*(rij-ssxm)
17433           ed=delta_inv*(Ht*hd2-ssm*hd1)
17434           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
17435           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
17436           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
17437         else
17438           havebond=.false.
17439           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17440           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
17441           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
17442           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
17443                alf12/eps3rt)
17444           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
17445           f1=(rij-ljxm)/(xm-ljxm)
17446           f2=(rij-xm)/(ljxm-xm)
17447           h1=h_base(f1,hd1)
17448           h2=h_base(f2,hd2)
17449           eij=Ht*h1+ljm*h2
17450           delta_inv=1.0d0/(ljxm-xm)
17451           deltasq_inv=delta_inv*delta_inv
17452           fac=Ht*hd1-ljm*hd2
17453           fac1=deltasq_inv*fac*(ljxm-rij)
17454           fac2=deltasq_inv*fac*(rij-xm)
17455           ed=delta_inv*(ljm*hd2-Ht*hd1)
17456           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
17457           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
17458           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
17459         endif
17460 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17461
17462 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17463 !$$$        ssd=rij-ssXs
17464 !$$$        ljd=rij-ljXs
17465 !$$$        fac1=rij-ljxm
17466 !$$$        fac2=rij-ssxm
17467 !$$$
17468 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
17469 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
17470 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
17471 !$$$
17472 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
17473 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
17474 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17475 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17476 !$$$        d_ssm(3)=omega
17477 !$$$
17478 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
17479 !$$$        do k=1,3
17480 !$$$          d_ljm(k)=ljm*d_ljB(k)
17481 !$$$        enddo
17482 !$$$        ljm=ljm*ljB
17483 !$$$
17484 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
17485 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
17486 !$$$        d_ss(2)=akct*ssd
17487 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
17488 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
17489 !$$$        d_ss(3)=omega
17490 !$$$
17491 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
17492 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
17493 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
17494 !$$$        do k=1,3
17495 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
17496 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
17497 !$$$        enddo
17498 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
17499 !$$$
17500 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
17501 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
17502 !$$$        h1=h_base(f1,hd1)
17503 !$$$        h2=h_base(f2,hd2)
17504 !$$$        eij=ss*h1+ljf*h2
17505 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
17506 !$$$        deltasq_inv=delta_inv*delta_inv
17507 !$$$        fac=ljf*hd2-ss*hd1
17508 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
17509 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
17510 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
17511 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
17512 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
17513 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
17514 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
17515 !$$$
17516 !$$$        havebond=.false.
17517 !$$$        if (ed.gt.0.0d0) havebond=.true.
17518 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17519
17520       endif
17521
17522       if (havebond) then
17523 !#ifndef CLUST
17524 !#ifndef WHAM
17525 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
17526 !          write(iout,'(a15,f12.2,f8.1,2i5)')
17527 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
17528 !        endif
17529 !#endif
17530 !#endif
17531         dyn_ssbond_ij(i,j)=eij
17532       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
17533         dyn_ssbond_ij(i,j)=1.0d300
17534 !#ifndef CLUST
17535 !#ifndef WHAM
17536 !        write(iout,'(a15,f12.2,f8.1,2i5)')
17537 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
17538 !#endif
17539 !#endif
17540       endif
17541
17542 !-------TESTING CODE
17543 !el      if (checkstop) then
17544         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
17545              "CHECKSTOP",rij,eij,ed
17546         echeck(jcheck)=eij
17547 !el      endif
17548       enddo
17549       if (checkstop) then
17550         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
17551       endif
17552       enddo
17553       if (checkstop) then
17554         transgrad=.true.
17555         checkstop=.false.
17556       endif
17557 !-------END TESTING CODE
17558
17559       do k=1,3
17560         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
17561         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
17562       enddo
17563       do k=1,3
17564         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
17565       enddo
17566       do k=1,3
17567         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
17568              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
17569              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
17570         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
17571              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
17572              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
17573       enddo
17574 !grad      do k=i,j-1
17575 !grad        do l=1,3
17576 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
17577 !grad        enddo
17578 !grad      enddo
17579
17580       do l=1,3
17581         gvdwc(l,i)=gvdwc(l,i)-gg(l)
17582         gvdwc(l,j)=gvdwc(l,j)+gg(l)
17583       enddo
17584
17585       return
17586       end subroutine dyn_ssbond_ene
17587 !-----------------------------------------------------------------------------
17588       real(kind=8) function h_base(x,deriv)
17589 !     A smooth function going 0->1 in range [0,1]
17590 !     It should NOT be called outside range [0,1], it will not work there.
17591       implicit none
17592
17593 !     Input arguments
17594       real(kind=8) :: x
17595
17596 !     Output arguments
17597       real(kind=8) :: deriv
17598
17599 !     Local variables
17600       real(kind=8) :: xsq
17601
17602
17603 !     Two parabolas put together.  First derivative zero at extrema
17604 !$$$      if (x.lt.0.5D0) then
17605 !$$$        h_base=2.0D0*x*x
17606 !$$$        deriv=4.0D0*x
17607 !$$$      else
17608 !$$$        deriv=1.0D0-x
17609 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
17610 !$$$        deriv=4.0D0*deriv
17611 !$$$      endif
17612
17613 !     Third degree polynomial.  First derivative zero at extrema
17614       h_base=x*x*(3.0d0-2.0d0*x)
17615       deriv=6.0d0*x*(1.0d0-x)
17616
17617 !     Fifth degree polynomial.  First and second derivatives zero at extrema
17618 !$$$      xsq=x*x
17619 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
17620 !$$$      deriv=x-1.0d0
17621 !$$$      deriv=deriv*deriv
17622 !$$$      deriv=30.0d0*xsq*deriv
17623
17624       return
17625       end function h_base
17626 !-----------------------------------------------------------------------------
17627       subroutine dyn_set_nss
17628 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
17629 !      implicit none
17630       use MD_data, only: totT,t_bath
17631 !     Includes
17632 !      include 'DIMENSIONS'
17633 #ifdef MPI
17634       include "mpif.h"
17635 #endif
17636 !      include 'COMMON.SBRIDGE'
17637 !      include 'COMMON.CHAIN'
17638 !      include 'COMMON.IOUNITS'
17639 !      include 'COMMON.SETUP'
17640 !      include 'COMMON.MD'
17641 !     Local variables
17642       real(kind=8) :: emin
17643       integer :: i,j,imin,ierr
17644       integer :: diff,allnss,newnss
17645       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
17646                 newihpb,newjhpb
17647       logical :: found
17648       integer,dimension(0:nfgtasks) :: i_newnss
17649       integer,dimension(0:nfgtasks) :: displ
17650       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
17651       integer :: g_newnss
17652
17653       allnss=0
17654       do i=1,nres-1
17655         do j=i+1,nres
17656           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
17657             allnss=allnss+1
17658             allflag(allnss)=0
17659             allihpb(allnss)=i
17660             alljhpb(allnss)=j
17661           endif
17662         enddo
17663       enddo
17664
17665 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
17666
17667  1    emin=1.0d300
17668       do i=1,allnss
17669         if (allflag(i).eq.0 .and. &
17670              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
17671           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
17672           imin=i
17673         endif
17674       enddo
17675       if (emin.lt.1.0d300) then
17676         allflag(imin)=1
17677         do i=1,allnss
17678           if (allflag(i).eq.0 .and. &
17679                (allihpb(i).eq.allihpb(imin) .or. &
17680                alljhpb(i).eq.allihpb(imin) .or. &
17681                allihpb(i).eq.alljhpb(imin) .or. &
17682                alljhpb(i).eq.alljhpb(imin))) then
17683             allflag(i)=-1
17684           endif
17685         enddo
17686         goto 1
17687       endif
17688
17689 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
17690
17691       newnss=0
17692       do i=1,allnss
17693         if (allflag(i).eq.1) then
17694           newnss=newnss+1
17695           newihpb(newnss)=allihpb(i)
17696           newjhpb(newnss)=alljhpb(i)
17697         endif
17698       enddo
17699
17700 #ifdef MPI
17701       if (nfgtasks.gt.1)then
17702
17703         call MPI_Reduce(newnss,g_newnss,1,&
17704           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
17705         call MPI_Gather(newnss,1,MPI_INTEGER,&
17706                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
17707         displ(0)=0
17708         do i=1,nfgtasks-1,1
17709           displ(i)=i_newnss(i-1)+displ(i-1)
17710         enddo
17711         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
17712                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
17713                          king,FG_COMM,IERR)
17714         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
17715                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
17716                          king,FG_COMM,IERR)
17717         if(fg_rank.eq.0) then
17718 !         print *,'g_newnss',g_newnss
17719 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
17720 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
17721          newnss=g_newnss
17722          do i=1,newnss
17723           newihpb(i)=g_newihpb(i)
17724           newjhpb(i)=g_newjhpb(i)
17725          enddo
17726         endif
17727       endif
17728 #endif
17729
17730       diff=newnss-nss
17731
17732 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
17733
17734       do i=1,nss
17735         found=.false.
17736         do j=1,newnss
17737           if (idssb(i).eq.newihpb(j) .and. &
17738                jdssb(i).eq.newjhpb(j)) found=.true.
17739         enddo
17740 #ifndef CLUST
17741 #ifndef WHAM
17742         if (.not.found.and.fg_rank.eq.0) &
17743             write(iout,'(a15,f12.2,f8.1,2i5)') &
17744              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
17745 #endif
17746 #endif
17747       enddo
17748
17749       do i=1,newnss
17750         found=.false.
17751         do j=1,nss
17752           if (newihpb(i).eq.idssb(j) .and. &
17753                newjhpb(i).eq.jdssb(j)) found=.true.
17754         enddo
17755 #ifndef CLUST
17756 #ifndef WHAM
17757         if (.not.found.and.fg_rank.eq.0) &
17758             write(iout,'(a15,f12.2,f8.1,2i5)') &
17759              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
17760 #endif
17761 #endif
17762       enddo
17763
17764       nss=newnss
17765       do i=1,nss
17766         idssb(i)=newihpb(i)
17767         jdssb(i)=newjhpb(i)
17768       enddo
17769
17770       return
17771       end subroutine dyn_set_nss
17772 ! Lipid transfer energy function
17773       subroutine Eliptransfer(eliptran)
17774 !C this is done by Adasko
17775 !C      print *,"wchodze"
17776 !C structure of box:
17777 !C      water
17778 !C--bordliptop-- buffore starts
17779 !C--bufliptop--- here true lipid starts
17780 !C      lipid
17781 !C--buflipbot--- lipid ends buffore starts
17782 !C--bordlipbot--buffore ends
17783       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
17784       integer :: i
17785       eliptran=0.0
17786       print *, "I am in eliptran"
17787       do i=ilip_start,ilip_end
17788 !C       do i=1,1
17789         if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1).or.(i.eq.nres))&
17790          cycle
17791
17792         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
17793         if (positi.le.0.0) positi=positi+boxzsize
17794 !C        print *,i
17795 !C first for peptide groups
17796 !c for each residue check if it is in lipid or lipid water border area
17797        if ((positi.gt.bordlipbot)  &
17798       .and.(positi.lt.bordliptop)) then
17799 !C the energy transfer exist
17800         if (positi.lt.buflipbot) then
17801 !C what fraction I am in
17802          fracinbuf=1.0d0-      &
17803              ((positi-bordlipbot)/lipbufthick)
17804 !C lipbufthick is thickenes of lipid buffore
17805          sslip=sscalelip(fracinbuf)
17806          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
17807          eliptran=eliptran+sslip*pepliptran
17808          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
17809          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
17810 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
17811
17812 !C        print *,"doing sccale for lower part"
17813 !C         print *,i,sslip,fracinbuf,ssgradlip
17814         elseif (positi.gt.bufliptop) then
17815          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
17816          sslip=sscalelip(fracinbuf)
17817          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
17818          eliptran=eliptran+sslip*pepliptran
17819          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
17820          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
17821 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
17822 !C          print *, "doing sscalefor top part"
17823 !C         print *,i,sslip,fracinbuf,ssgradlip
17824         else
17825          eliptran=eliptran+pepliptran
17826 !C         print *,"I am in true lipid"
17827         endif
17828 !C       else
17829 !C       eliptran=elpitran+0.0 ! I am in water
17830        endif
17831        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
17832        enddo
17833 ! here starts the side chain transfer
17834        do i=ilip_start,ilip_end
17835         if (itype(i).eq.ntyp1) cycle
17836         positi=(mod(c(3,i+nres),boxzsize))
17837         if (positi.le.0) positi=positi+boxzsize
17838 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
17839 !c for each residue check if it is in lipid or lipid water border area
17840 !C       respos=mod(c(3,i+nres),boxzsize)
17841 !C       print *,positi,bordlipbot,buflipbot
17842        if ((positi.gt.bordlipbot) &
17843        .and.(positi.lt.bordliptop)) then
17844 !C the energy transfer exist
17845         if (positi.lt.buflipbot) then
17846          fracinbuf=1.0d0-   &
17847            ((positi-bordlipbot)/lipbufthick)
17848 !C lipbufthick is thickenes of lipid buffore
17849          sslip=sscalelip(fracinbuf)
17850          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
17851          eliptran=eliptran+sslip*liptranene(itype(i))
17852          gliptranx(3,i)=gliptranx(3,i) &
17853       +ssgradlip*liptranene(itype(i))
17854          gliptranc(3,i-1)= gliptranc(3,i-1) &
17855       +ssgradlip*liptranene(itype(i))
17856 !C         print *,"doing sccale for lower part"
17857         elseif (positi.gt.bufliptop) then
17858          fracinbuf=1.0d0-  &
17859       ((bordliptop-positi)/lipbufthick)
17860          sslip=sscalelip(fracinbuf)
17861          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
17862          eliptran=eliptran+sslip*liptranene(itype(i))
17863          gliptranx(3,i)=gliptranx(3,i)  &
17864        +ssgradlip*liptranene(itype(i))
17865          gliptranc(3,i-1)= gliptranc(3,i-1) &
17866       +ssgradlip*liptranene(itype(i))
17867 !C          print *, "doing sscalefor top part",sslip,fracinbuf
17868         else
17869          eliptran=eliptran+liptranene(itype(i))
17870 !C         print *,"I am in true lipid"
17871         endif
17872         endif ! if in lipid or buffor
17873 !C       else
17874 !C       eliptran=elpitran+0.0 ! I am in water
17875         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
17876        enddo
17877        return
17878        end  subroutine Eliptransfer
17879 !--------------------------------------------------------------------------------
17880 !C first for shielding is setting of function of side-chains
17881
17882        subroutine set_shield_fac2
17883        real(kind=8) :: div77_81=0.974996043d0, &
17884         div4_81=0.2222222222d0
17885        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
17886          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
17887          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
17888          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
17889 !C the vector between center of side_chain and peptide group
17890        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
17891          pept_group,costhet_grad,cosphi_grad_long, &
17892          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
17893          sh_frac_dist_grad,pep_side
17894         integer i,j,k
17895 !C      write(2,*) "ivec",ivec_start,ivec_end
17896       do i=1,nres
17897         fac_shield(i)=0.0d0
17898         do j=1,3
17899         grad_shield(j,i)=0.0d0
17900         enddo
17901       enddo
17902       do i=ivec_start,ivec_end
17903 !C      do i=1,nres-1
17904 !C      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
17905       ishield_list(i)=0
17906       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
17907 !Cif there two consequtive dummy atoms there is no peptide group between them
17908 !C the line below has to be changed for FGPROC>1
17909       VolumeTotal=0.0
17910       do k=1,nres
17911        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
17912        dist_pep_side=0.0
17913        dist_side_calf=0.0
17914        do j=1,3
17915 !C first lets set vector conecting the ithe side-chain with kth side-chain
17916       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
17917 !C      pep_side(j)=2.0d0
17918 !C and vector conecting the side-chain with its proper calfa
17919       side_calf(j)=c(j,k+nres)-c(j,k)
17920 !C      side_calf(j)=2.0d0
17921       pept_group(j)=c(j,i)-c(j,i+1)
17922 !C lets have their lenght
17923       dist_pep_side=pep_side(j)**2+dist_pep_side
17924       dist_side_calf=dist_side_calf+side_calf(j)**2
17925       dist_pept_group=dist_pept_group+pept_group(j)**2
17926       enddo
17927        dist_pep_side=sqrt(dist_pep_side)
17928        dist_pept_group=sqrt(dist_pept_group)
17929        dist_side_calf=sqrt(dist_side_calf)
17930       do j=1,3
17931         pep_side_norm(j)=pep_side(j)/dist_pep_side
17932         side_calf_norm(j)=dist_side_calf
17933       enddo
17934 !C now sscale fraction
17935        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
17936 !C       print *,buff_shield,"buff"
17937 !C now sscale
17938         if (sh_frac_dist.le.0.0) cycle
17939 !C        print *,ishield_list(i),i
17940 !C If we reach here it means that this side chain reaches the shielding sphere
17941 !C Lets add him to the list for gradient
17942         ishield_list(i)=ishield_list(i)+1
17943 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
17944 !C this list is essential otherwise problem would be O3
17945         shield_list(ishield_list(i),i)=k
17946 !C Lets have the sscale value
17947         if (sh_frac_dist.gt.1.0) then
17948          scale_fac_dist=1.0d0
17949          do j=1,3
17950          sh_frac_dist_grad(j)=0.0d0
17951          enddo
17952         else
17953          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
17954                         *(2.0d0*sh_frac_dist-3.0d0)
17955          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
17956                        /dist_pep_side/buff_shield*0.5d0
17957          do j=1,3
17958          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
17959 !C         sh_frac_dist_grad(j)=0.0d0
17960 !C         scale_fac_dist=1.0d0
17961 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
17962 !C     &                    sh_frac_dist_grad(j)
17963          enddo
17964         endif
17965 !C this is what is now we have the distance scaling now volume...
17966       short=short_r_sidechain(itype(k))
17967       long=long_r_sidechain(itype(k))
17968       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
17969       sinthet=short/dist_pep_side*costhet
17970 !C now costhet_grad
17971 !C       costhet=0.6d0
17972 !C       sinthet=0.8
17973        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
17974 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
17975 !C     &             -short/dist_pep_side**2/costhet)
17976 !C       costhet_fac=0.0d0
17977        do j=1,3
17978          costhet_grad(j)=costhet_fac*pep_side(j)
17979        enddo
17980 !C remember for the final gradient multiply costhet_grad(j)
17981 !C for side_chain by factor -2 !
17982 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
17983 !C pep_side0pept_group is vector multiplication
17984       pep_side0pept_group=0.0d0
17985       do j=1,3
17986       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
17987       enddo
17988       cosalfa=(pep_side0pept_group/ &
17989       (dist_pep_side*dist_side_calf))
17990       fac_alfa_sin=1.0d0-cosalfa**2
17991       fac_alfa_sin=dsqrt(fac_alfa_sin)
17992       rkprim=fac_alfa_sin*(long-short)+short
17993 !C      rkprim=short
17994
17995 !C now costhet_grad
17996        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
17997 !C       cosphi=0.6
17998        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
17999        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
18000            dist_pep_side**2)
18001 !C       sinphi=0.8
18002        do j=1,3
18003          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
18004       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
18005       *(long-short)/fac_alfa_sin*cosalfa/ &
18006       ((dist_pep_side*dist_side_calf))* &
18007       ((side_calf(j))-cosalfa* &
18008       ((pep_side(j)/dist_pep_side)*dist_side_calf))
18009 !C       cosphi_grad_long(j)=0.0d0
18010         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
18011       *(long-short)/fac_alfa_sin*cosalfa &
18012       /((dist_pep_side*dist_side_calf))* &
18013       (pep_side(j)- &
18014       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
18015 !C       cosphi_grad_loc(j)=0.0d0
18016        enddo
18017 !C      print *,sinphi,sinthet
18018       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
18019      &                    /VSolvSphere_div
18020 !C     &                    *wshield
18021 !C now the gradient...
18022       do j=1,3
18023       grad_shield(j,i)=grad_shield(j,i) &
18024 !C gradient po skalowaniu
18025                      +(sh_frac_dist_grad(j)*VofOverlap &
18026 !C  gradient po costhet
18027             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
18028         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
18029             sinphi/sinthet*costhet*costhet_grad(j) &
18030            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
18031         )*wshield
18032 !C grad_shield_side is Cbeta sidechain gradient
18033       grad_shield_side(j,ishield_list(i),i)=&
18034              (sh_frac_dist_grad(j)*-2.0d0&
18035              *VofOverlap&
18036             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
18037        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
18038             sinphi/sinthet*costhet*costhet_grad(j)&
18039            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
18040             )*wshield
18041
18042        grad_shield_loc(j,ishield_list(i),i)=   &
18043             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
18044       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
18045             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
18046              ))&
18047              *wshield
18048       enddo
18049       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
18050       enddo
18051       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
18052
18053       write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
18054       enddo
18055       return
18056       end subroutine set_shield_fac2
18057
18058 !-----------------------------------------------------------------------------
18059 #ifdef WHAM
18060       subroutine read_ssHist
18061 !      implicit none
18062 !      Includes
18063 !      include 'DIMENSIONS'
18064 !      include "DIMENSIONS.FREE"
18065 !      include 'COMMON.FREE'
18066 !     Local variables
18067       integer :: i,j
18068       character(len=80) :: controlcard
18069
18070       do i=1,dyn_nssHist
18071         call card_concat(controlcard,.true.)
18072         read(controlcard,*) &
18073              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
18074       enddo
18075
18076       return
18077       end subroutine read_ssHist
18078 #endif
18079 !-----------------------------------------------------------------------------
18080       integer function indmat(i,j)
18081 !el
18082 ! get the position of the jth ijth fragment of the chain coordinate system
18083 ! in the fromto array.
18084         integer :: i,j
18085
18086         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
18087       return
18088       end function indmat
18089 !-----------------------------------------------------------------------------
18090       real(kind=8) function sigm(x)
18091 !el
18092        real(kind=8) :: x
18093         sigm=0.25d0*x
18094       return
18095       end function sigm
18096 !-----------------------------------------------------------------------------
18097 !-----------------------------------------------------------------------------
18098       subroutine alloc_ener_arrays
18099 !EL Allocation of arrays used by module energy
18100       use MD_data, only: mset
18101 !el local variables
18102       integer :: i,j
18103
18104       if(nres.lt.100) then
18105         maxconts=nres
18106       elseif(nres.lt.200) then
18107         maxconts=0.8*nres       ! Max. number of contacts per residue
18108       else
18109         maxconts=0.6*nres ! (maxconts=maxres/4)
18110       endif
18111       maxcont=12*nres   ! Max. number of SC contacts
18112       maxvar=6*nres     ! Max. number of variables
18113 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
18114       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
18115 !----------------------
18116 ! arrays in subroutine init_int_table
18117 !el#ifdef MPI
18118 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
18119 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
18120 !el#endif
18121       allocate(nint_gr(nres))
18122       allocate(nscp_gr(nres))
18123       allocate(ielstart(nres))
18124       allocate(ielend(nres))
18125 !(maxres)
18126       allocate(istart(nres,maxint_gr))
18127       allocate(iend(nres,maxint_gr))
18128 !(maxres,maxint_gr)
18129       allocate(iscpstart(nres,maxint_gr))
18130       allocate(iscpend(nres,maxint_gr))
18131 !(maxres,maxint_gr)
18132       allocate(ielstart_vdw(nres))
18133       allocate(ielend_vdw(nres))
18134 !(maxres)
18135
18136       allocate(lentyp(0:nfgtasks-1))
18137 !(0:maxprocs-1)
18138 !----------------------
18139 ! commom.contacts
18140 !      common /contacts/
18141       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
18142       allocate(icont(2,maxcont))
18143 !(2,maxcont)
18144 !      common /contacts1/
18145       allocate(num_cont(0:nres+4))
18146 !(maxres)
18147       allocate(jcont(maxconts,nres))
18148 !(maxconts,maxres)
18149       allocate(facont(maxconts,nres))
18150 !(maxconts,maxres)
18151       allocate(gacont(3,maxconts,nres))
18152 !(3,maxconts,maxres)
18153 !      common /contacts_hb/
18154       allocate(gacontp_hb1(3,maxconts,nres))
18155       allocate(gacontp_hb2(3,maxconts,nres))
18156       allocate(gacontp_hb3(3,maxconts,nres))
18157       allocate(gacontm_hb1(3,maxconts,nres))
18158       allocate(gacontm_hb2(3,maxconts,nres))
18159       allocate(gacontm_hb3(3,maxconts,nres))
18160       allocate(gacont_hbr(3,maxconts,nres))
18161       allocate(grij_hb_cont(3,maxconts,nres))
18162 !(3,maxconts,maxres)
18163       allocate(facont_hb(maxconts,nres))
18164
18165       allocate(ees0p(maxconts,nres))
18166       allocate(ees0m(maxconts,nres))
18167       allocate(d_cont(maxconts,nres))
18168       allocate(ees0plist(maxconts,nres))
18169
18170 !(maxconts,maxres)
18171       allocate(num_cont_hb(nres))
18172 !(maxres)
18173       allocate(jcont_hb(maxconts,nres))
18174 !(maxconts,maxres)
18175 !      common /rotat/
18176       allocate(Ug(2,2,nres))
18177       allocate(Ugder(2,2,nres))
18178       allocate(Ug2(2,2,nres))
18179       allocate(Ug2der(2,2,nres))
18180 !(2,2,maxres)
18181       allocate(obrot(2,nres))
18182       allocate(obrot2(2,nres))
18183       allocate(obrot_der(2,nres))
18184       allocate(obrot2_der(2,nres))
18185 !(2,maxres)
18186 !      common /precomp1/
18187       allocate(mu(2,nres))
18188       allocate(muder(2,nres))
18189       allocate(Ub2(2,nres))
18190       Ub2(1,:)=0.0d0
18191       Ub2(2,:)=0.0d0
18192       allocate(Ub2der(2,nres))
18193       allocate(Ctobr(2,nres))
18194       allocate(Ctobrder(2,nres))
18195       allocate(Dtobr2(2,nres))
18196       allocate(Dtobr2der(2,nres))
18197 !(2,maxres)
18198       allocate(EUg(2,2,nres))
18199       allocate(EUgder(2,2,nres))
18200       allocate(CUg(2,2,nres))
18201       allocate(CUgder(2,2,nres))
18202       allocate(DUg(2,2,nres))
18203       allocate(Dugder(2,2,nres))
18204       allocate(DtUg2(2,2,nres))
18205       allocate(DtUg2der(2,2,nres))
18206 !(2,2,maxres)
18207 !      common /precomp2/
18208       allocate(Ug2Db1t(2,nres))
18209       allocate(Ug2Db1tder(2,nres))
18210       allocate(CUgb2(2,nres))
18211       allocate(CUgb2der(2,nres))
18212 !(2,maxres)
18213       allocate(EUgC(2,2,nres))
18214       allocate(EUgCder(2,2,nres))
18215       allocate(EUgD(2,2,nres))
18216       allocate(EUgDder(2,2,nres))
18217       allocate(DtUg2EUg(2,2,nres))
18218       allocate(Ug2DtEUg(2,2,nres))
18219 !(2,2,maxres)
18220       allocate(Ug2DtEUgder(2,2,2,nres))
18221       allocate(DtUg2EUgder(2,2,2,nres))
18222 !(2,2,2,maxres)
18223 !      common /rotat_old/
18224       allocate(costab(nres))
18225       allocate(sintab(nres))
18226       allocate(costab2(nres))
18227       allocate(sintab2(nres))
18228 !(maxres)
18229 !      common /dipmat/
18230       allocate(a_chuj(2,2,maxconts,nres))
18231 !(2,2,maxconts,maxres)(maxconts=maxres/4)
18232       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
18233 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
18234 !      common /contdistrib/
18235       allocate(ncont_sent(nres))
18236       allocate(ncont_recv(nres))
18237
18238       allocate(iat_sent(nres))
18239 !(maxres)
18240       allocate(iint_sent(4,nres,nres))
18241       allocate(iint_sent_local(4,nres,nres))
18242 !(4,maxres,maxres)
18243       allocate(iturn3_sent(4,0:nres+4))
18244       allocate(iturn4_sent(4,0:nres+4))
18245       allocate(iturn3_sent_local(4,nres))
18246       allocate(iturn4_sent_local(4,nres))
18247 !(4,maxres)
18248       allocate(itask_cont_from(0:nfgtasks-1))
18249       allocate(itask_cont_to(0:nfgtasks-1))
18250 !(0:max_fg_procs-1)
18251
18252
18253
18254 !----------------------
18255 ! commom.deriv;
18256 !      common /derivat/
18257       allocate(dcdv(6,maxdim))
18258       allocate(dxdv(6,maxdim))
18259 !(6,maxdim)
18260       allocate(dxds(6,nres))
18261 !(6,maxres)
18262       allocate(gradx(3,-1:nres,0:2))
18263       allocate(gradc(3,-1:nres,0:2))
18264 !(3,maxres,2)
18265       allocate(gvdwx(3,-1:nres))
18266       allocate(gvdwc(3,-1:nres))
18267       allocate(gelc(3,-1:nres))
18268       allocate(gelc_long(3,-1:nres))
18269       allocate(gvdwpp(3,-1:nres))
18270       allocate(gvdwc_scpp(3,-1:nres))
18271       allocate(gradx_scp(3,-1:nres))
18272       allocate(gvdwc_scp(3,-1:nres))
18273       allocate(ghpbx(3,-1:nres))
18274       allocate(ghpbc(3,-1:nres))
18275       allocate(gradcorr(3,-1:nres))
18276       allocate(gradcorr_long(3,-1:nres))
18277       allocate(gradcorr5_long(3,-1:nres))
18278       allocate(gradcorr6_long(3,-1:nres))
18279       allocate(gcorr6_turn_long(3,-1:nres))
18280       allocate(gradxorr(3,-1:nres))
18281       allocate(gradcorr5(3,-1:nres))
18282       allocate(gradcorr6(3,-1:nres))
18283       allocate(gliptran(3,-1:nres))
18284       allocate(gliptranc(3,-1:nres))
18285       allocate(gliptranx(3,-1:nres))
18286       allocate(gshieldx(3,-1:nres))
18287       allocate(gshieldc(3,-1:nres))
18288       allocate(gshieldc_loc(3,-1:nres))
18289       allocate(gshieldx_ec(3,-1:nres))
18290       allocate(gshieldc_ec(3,-1:nres))
18291       allocate(gshieldc_loc_ec(3,-1:nres))
18292       allocate(gshieldx_t3(3,-1:nres))
18293       allocate(gshieldc_t3(3,-1:nres))
18294       allocate(gshieldc_loc_t3(3,-1:nres))
18295       allocate(gshieldx_t4(3,-1:nres))
18296       allocate(gshieldc_t4(3,-1:nres))
18297       allocate(gshieldc_loc_t4(3,-1:nres))
18298       allocate(gshieldx_ll(3,-1:nres))
18299       allocate(gshieldc_ll(3,-1:nres))
18300       allocate(gshieldc_loc_ll(3,-1:nres))
18301       allocate(grad_shield(3,-1:nres))
18302 !(3,maxres)
18303       allocate(grad_shield_side(3,50,nres))
18304       allocate(grad_shield_loc(3,50,nres))
18305 ! grad for shielding surroing
18306       allocate(gloc(0:maxvar,0:2))
18307       allocate(gloc_x(0:maxvar,2))
18308 !(maxvar,2)
18309       allocate(gel_loc(3,-1:nres))
18310       allocate(gel_loc_long(3,-1:nres))
18311       allocate(gcorr3_turn(3,-1:nres))
18312       allocate(gcorr4_turn(3,-1:nres))
18313       allocate(gcorr6_turn(3,-1:nres))
18314       allocate(gradb(3,-1:nres))
18315       allocate(gradbx(3,-1:nres))
18316 !(3,maxres)
18317       allocate(gel_loc_loc(maxvar))
18318       allocate(gel_loc_turn3(maxvar))
18319       allocate(gel_loc_turn4(maxvar))
18320       allocate(gel_loc_turn6(maxvar))
18321       allocate(gcorr_loc(maxvar))
18322       allocate(g_corr5_loc(maxvar))
18323       allocate(g_corr6_loc(maxvar))
18324 !(maxvar)
18325       allocate(gsccorc(3,-1:nres))
18326       allocate(gsccorx(3,-1:nres))
18327 !(3,maxres)
18328       allocate(gsccor_loc(-1:nres))
18329 !(maxres)
18330       allocate(dtheta(3,2,-1:nres))
18331 !(3,2,maxres)
18332       allocate(gscloc(3,-1:nres))
18333       allocate(gsclocx(3,-1:nres))
18334 !(3,maxres)
18335       allocate(dphi(3,3,-1:nres))
18336       allocate(dalpha(3,3,-1:nres))
18337       allocate(domega(3,3,-1:nres))
18338 !(3,3,maxres)
18339 !      common /deriv_scloc/
18340       allocate(dXX_C1tab(3,nres))
18341       allocate(dYY_C1tab(3,nres))
18342       allocate(dZZ_C1tab(3,nres))
18343       allocate(dXX_Ctab(3,nres))
18344       allocate(dYY_Ctab(3,nres))
18345       allocate(dZZ_Ctab(3,nres))
18346       allocate(dXX_XYZtab(3,nres))
18347       allocate(dYY_XYZtab(3,nres))
18348       allocate(dZZ_XYZtab(3,nres))
18349 !(3,maxres)
18350 !      common /mpgrad/
18351       allocate(jgrad_start(nres))
18352       allocate(jgrad_end(nres))
18353 !(maxres)
18354 !----------------------
18355
18356 !      common /indices/
18357       allocate(ibond_displ(0:nfgtasks-1))
18358       allocate(ibond_count(0:nfgtasks-1))
18359       allocate(ithet_displ(0:nfgtasks-1))
18360       allocate(ithet_count(0:nfgtasks-1))
18361       allocate(iphi_displ(0:nfgtasks-1))
18362       allocate(iphi_count(0:nfgtasks-1))
18363       allocate(iphi1_displ(0:nfgtasks-1))
18364       allocate(iphi1_count(0:nfgtasks-1))
18365       allocate(ivec_displ(0:nfgtasks-1))
18366       allocate(ivec_count(0:nfgtasks-1))
18367       allocate(iset_displ(0:nfgtasks-1))
18368       allocate(iset_count(0:nfgtasks-1))
18369       allocate(iint_count(0:nfgtasks-1))
18370       allocate(iint_displ(0:nfgtasks-1))
18371 !(0:max_fg_procs-1)
18372 !----------------------
18373 ! common.MD
18374 !      common /mdgrad/
18375       allocate(gcart(3,-1:nres))
18376       allocate(gxcart(3,-1:nres))
18377 !(3,0:MAXRES)
18378       allocate(gradcag(3,-1:nres))
18379       allocate(gradxag(3,-1:nres))
18380 !(3,MAXRES)
18381 !      common /back_constr/
18382 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
18383       allocate(dutheta(nres))
18384       allocate(dugamma(nres))
18385 !(maxres)
18386       allocate(duscdiff(3,nres))
18387       allocate(duscdiffx(3,nres))
18388 !(3,maxres)
18389 !el i io:read_fragments
18390 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
18391 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
18392 !      common /qmeas/
18393 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
18394 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
18395       allocate(mset(0:nprocs))  !(maxprocs/20)
18396       mset(:)=0
18397 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
18398 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
18399       allocate(dUdconst(3,0:nres))
18400       allocate(dUdxconst(3,0:nres))
18401       allocate(dqwol(3,0:nres))
18402       allocate(dxqwol(3,0:nres))
18403 !(3,0:MAXRES)
18404 !----------------------
18405 ! common.sbridge
18406 !      common /sbridge/ in io_common: read_bridge
18407 !el    allocate((:),allocatable :: iss  !(maxss)
18408 !      common /links/  in io_common: read_bridge
18409 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
18410 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
18411 !      common /dyn_ssbond/
18412 ! and side-chain vectors in theta or phi.
18413       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
18414 !(maxres,maxres)
18415 !      do i=1,nres
18416 !        do j=i+1,nres
18417       dyn_ssbond_ij(:,:)=1.0d300
18418 !        enddo
18419 !      enddo
18420
18421       if (nss.gt.0) then
18422         allocate(idssb(nss),jdssb(nss))
18423 !(maxdim)
18424       endif
18425       allocate(ishield_list(nres))
18426       allocate(shield_list(50,nres))
18427       allocate(dyn_ss_mask(nres))
18428       allocate(fac_shield(nres))
18429 !(maxres)
18430       dyn_ss_mask(:)=.false.
18431 !----------------------
18432 ! common.sccor
18433 ! Parameters of the SCCOR term
18434 !      common/sccor/
18435 !el in io_conf: parmread
18436 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
18437 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
18438 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
18439 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
18440 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
18441 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
18442 !      allocate(vlor1sccor(maxterm_sccor,20,20))
18443 !      allocate(vlor2sccor(maxterm_sccor,20,20))
18444 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
18445 !----------------
18446       allocate(gloc_sc(3,0:2*nres,0:10))
18447 !(3,0:maxres2,10)maxres2=2*maxres
18448       allocate(dcostau(3,3,3,2*nres))
18449       allocate(dsintau(3,3,3,2*nres))
18450       allocate(dtauangle(3,3,3,2*nres))
18451       allocate(dcosomicron(3,3,3,2*nres))
18452       allocate(domicron(3,3,3,2*nres))
18453 !(3,3,3,maxres2)maxres2=2*maxres
18454 !----------------------
18455 ! common.var
18456 !      common /restr/
18457       allocate(varall(maxvar))
18458 !(maxvar)(maxvar=6*maxres)
18459       allocate(mask_theta(nres))
18460       allocate(mask_phi(nres))
18461       allocate(mask_side(nres))
18462 !(maxres)
18463 !----------------------
18464 ! common.vectors
18465 !      common /vectors/
18466       allocate(uy(3,nres))
18467       allocate(uz(3,nres))
18468 !(3,maxres)
18469       allocate(uygrad(3,3,2,nres))
18470       allocate(uzgrad(3,3,2,nres))
18471 !(3,3,2,maxres)
18472
18473       return
18474       end subroutine alloc_ener_arrays
18475 !-----------------------------------------------------------------------------
18476 !-----------------------------------------------------------------------------
18477       end module energy