source/unres/energy.f90

   1       module energy
   2 !-----------------------------------------------------------------------------
   3       use io_units
   4       use names
   5       use math
   6       use MPI_data
   7       use energy_data
   8       use control_data
   9       use geometry_data
  10       use geometry
  11 !
  12       implicit none
  13 !-----------------------------------------------------------------------------
  14 ! Max. number of contacts per residue
  15 !      integer :: maxconts
  16 !-----------------------------------------------------------------------------
  17 ! Max. number of derivatives of virtual-bond and side-chain vectors in theta
  18 ! or phi.
  19 !      integer :: maxdim
  20 !-----------------------------------------------------------------------------
  21 ! Max. number of SC contacts
  22 !      integer :: maxcont
  23 !-----------------------------------------------------------------------------
  24 ! Max. number of variables
  25       integer :: maxvar
  26 !-----------------------------------------------------------------------------
  27 ! Max number of torsional terms in SCCOR  in control_data
  28 !      integer,parameter :: maxterm_sccor=6
  29 !-----------------------------------------------------------------------------
  30 ! Maximum number of SC local term fitting function coefficiants
  31       integer,parameter :: maxsccoef=65
  32 ! Maximum number of local shielding effectors
  33       integer,parameter :: maxcontsshi=50
  34 !-----------------------------------------------------------------------------
  35 ! commom.calc common/calc/
  36 !-----------------------------------------------------------------------------
  37 ! commom.contacts
  38 !      common /contacts/
  39 ! Change 12/1/95 - common block CONTACTS1 included.
  40 !      common /contacts1/
  41
  42       integer,dimension(:),allocatable :: num_cont      !(maxres)
  43       integer,dimension(:,:),allocatable :: jcont      !(maxconts,maxres)
  44       real(kind=8),dimension(:,:),allocatable :: facont,ees0plist      !(maxconts,maxres)
  45       real(kind=8),dimension(:,:,:),allocatable :: gacont      !(3,maxconts,maxres)
  46       integer,dimension(:),allocatable :: ishield_list
  47       integer,dimension(:,:),allocatable ::  shield_list
  48       real(kind=8),dimension(:),allocatable :: enetube,enecavtube
  49 !
  50 ! 12/26/95 - H-bonding contacts
  51 !      common /contacts_hb/
  52       real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,&
  53        gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont      !(3,maxconts,maxres)
  54       real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,&
  55         ees0m,d_cont      !(maxconts,maxres)
  56       integer,dimension(:),allocatable :: num_cont_hb      !(maxres)
  57       integer,dimension(:,:),allocatable :: jcont_hb      !(maxconts,maxres)
  58 ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
  59 !         interactions
  60 ! 7/25/08 commented out; not needed when cumulants used
  61 ! Interactions of pseudo-dipoles generated by loc-el interactions.
  62 !  common /dipint/
  63       real(kind=8),dimension(:,:,:),allocatable :: dip,&
  64          dipderg      !(4,maxconts,maxres)
  65       real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres)
  66 ! 10/30/99 Added other pre-computed vectors and matrices needed
  67 !          to calculate three - six-order el-loc correlation terms
  68 ! common /rotat/
  69       real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der      !(2,2,maxres)
  70       real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,&
  71        obrot2_der      !(2,maxres)
  72 !
  73 ! This common block contains vectors and matrices dependent on a single
  74 ! amino-acid residue.
  75 !      common /precomp1/
  76       real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,&
  77        Ctobr,Ctobrder,Dtobr2,Dtobr2der      !(2,maxres)
  78       real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,&
  79        CUgder,DUg,Dugder,DtUg2,DtUg2der      !(2,2,maxres)
  80 ! This common block contains vectors and matrices dependent on two
  81 ! consecutive amino-acid residues.
  82 !      common /precomp2/
  83       real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,&
  84        CUgb2,CUgb2der      !(2,maxres)
  85       real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,&
  86        EUgD,EUgDder,DtUg2EUg,Ug2DtEUg      !(2,2,maxres)
  87       real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,&
  88        DtUg2EUgder      !(2,2,2,maxres)
  89 !      common /rotat_old/
  90       real(kind=8),dimension(:),allocatable :: costab,sintab,&
  91        costab2,sintab2      !(maxres)
  92 ! This common block contains dipole-interaction matrices and their
  93 ! Cartesian derivatives.
  94 !      common /dipmat/
  95       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj      !(2,2,maxconts,maxres)
  96       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der      !(2,2,3,5,maxconts,maxres)
  97 !      common /diploc/
  98       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
  99        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
 100       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
 101        ADtEA1derg,AEAb2derg
 102       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
 103        AECAderx,ADtEAderx,ADtEA1derx
 104       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
 105       real(kind=8),dimension(3,2) :: g_contij
 106       real(kind=8) :: ekont
 107 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 108 !   RE: Parallelization of 4th and higher order loc-el correlations
 109 !      common /contdistrib/
 110       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 111 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 112 !-----------------------------------------------------------------------------
 113 ! commom.deriv;
 114 !      common /derivat/
 115 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 116 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 117 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 118       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 119         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 120         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 121         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6,gliptran,gliptranc,&
 122         gliptranx, &
 123         gshieldx,gshieldc,gshieldc_loc,gshieldx_ec,&
 124         gshieldc_ec,gshieldc_loc_ec,gshieldx_t3, &
 125         gshieldc_t3,gshieldc_loc_t3,gshieldx_t4,gshieldc_t4, &
 126         gshieldc_loc_t4,gshieldx_ll,gshieldc_ll,gshieldc_loc_ll,&
 127         grad_shield,gg_tube,gg_tube_sc,gradafm !(3,maxres)
 128 !-----------------------------NUCLEIC GRADIENT
 129       real(kind=8),dimension(:,:),allocatable  ::gradb_nucl,gradbx_nucl, &
 130         gvdwpsb1,gelpp,gvdwpsb,gelsbc,gelsbx,gvdwsbx,gvdwsbc,gsbloc,&
 131         gsblocx,gradcorr_nucl,gradxorr_nucl,gradcorr3_nucl,gradxorr3_nucl,&
 132         gvdwpp_nucl
 133 !------------------------------IONS GRADIENT
 134         real(kind=8),dimension(:,:),allocatable  ::  gradcatcat, &
 135           gradpepcat,gradpepcatx
 136 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 137       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 138         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 139       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 140         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 141         g_corr6_loc      !(maxvar)
 142       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 143       real(kind=8),dimension(:),allocatable :: gsccor_loc      !(maxres)
 144 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 145       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 146 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 147       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 148          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 149 !      integer :: nfl,icg
 150 !      common /deriv_loc/
 151       real(kind=8), dimension(:),allocatable :: fac_shield
 152       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 153 !      common /deriv_scloc/
 154       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 155        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 156        dZZ_XYZtab      !(3,maxres)
 157 !-----------------------------------------------------------------------------
 158 ! common.maxgrad
 159 !      common /maxgrad/
 160       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 161        gradb_max,ghpbc_max,&
 162        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 163        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 164        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 165        gsccorx_max,gsclocx_max
 166 !-----------------------------------------------------------------------------
 167 ! common.MD
 168 !      common /back_constr/
 169       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 170       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 171 !      common /qmeas/
 172       real(kind=8) :: Ucdfrag,Ucdpair
 173       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 174        dqwol,dxqwol      !(3,0:MAXRES)
 175 !-----------------------------------------------------------------------------
 176 ! common.sbridge
 177 !      common /dyn_ssbond/
 178       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 179 !-----------------------------------------------------------------------------
 180 ! common.sccor
 181 ! Parameters of the SCCOR term
 182 !      common/sccor/
 183       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 184        dcosomicron,domicron      !(3,3,3,maxres2)
 185 !-----------------------------------------------------------------------------
 186 ! common.vectors
 187 !      common /vectors/
 188       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 189       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 190 !-----------------------------------------------------------------------------
 191 ! common /przechowalnia/
 192       real(kind=8),dimension(:,:,:),allocatable :: zapas
 193       real(kind=8),dimension(:,:,:,:),allocatable ::zapas2 !(max_dim,maxconts,max_fg_procs)
 194       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 195 !-----------------------------------------------------------------------------
 196 !-----------------------------------------------------------------------------
 197 !
 198 !
 199 !-----------------------------------------------------------------------------
 200       contains
 201 !-----------------------------------------------------------------------------
 202 ! energy_p_new_barrier.F
 203 !-----------------------------------------------------------------------------
 204       subroutine etotal(energia)
 205 !      implicit real*8 (a-h,o-z)
 206 !      include 'DIMENSIONS'
 207       use MD_data
 208 #ifndef ISNAN
 209       external proc_proc
 210 #ifdef WINPGI
 211 !MS$ATTRIBUTES C ::  proc_proc
 212 #endif
 213 #endif
 214 #ifdef MPI
 215       include "mpif.h"
 216 #endif
 217 !      include 'COMMON.SETUP'
 218 !      include 'COMMON.IOUNITS'
 219       real(kind=8),dimension(0:n_ene) :: energia
 220 !      include 'COMMON.LOCAL'
 221 !      include 'COMMON.FFIELD'
 222 !      include 'COMMON.DERIV'
 223 !      include 'COMMON.INTERACT'
 224 !      include 'COMMON.SBRIDGE'
 225 !      include 'COMMON.CHAIN'
 226 !      include 'COMMON.VAR'
 227 !      include 'COMMON.MD'
 228 !      include 'COMMON.CONTROL'
 229 !      include 'COMMON.TIME1'
 230       real(kind=8) :: time00
 231 !el local variables
 232       integer :: n_corr,n_corr1,ierror
 233       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 234       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 235       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 236                       Eafmforce,ethetacnstr
 237       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 238 ! now energies for nulceic alone parameters
 239       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 240                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 241                       ecorr3_nucl
 242 ! energies for ions
 243       real(kind=8) :: ecation_prot,ecationcation
 244
 245 #ifdef MPI
 246       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 247 ! shielding effect varibles for MPI
 248 !      real(kind=8)   fac_shieldbuf(maxres),
 249 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 250 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 251 !     & grad_shieldbuf(3,-1:maxres)
 252 !       integer ishield_listbuf(maxres),
 253 !     &shield_listbuf(maxcontsshi,maxres)
 254
 255 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 256 !     & " nfgtasks",nfgtasks
 257       if (nfgtasks.gt.1) then
 258         time00=MPI_Wtime()
 259 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 260         if (fg_rank.eq.0) then
 261           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 262 !          print *,"Processor",myrank," BROADCAST iorder"
 263 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 264 ! FG slaves as WEIGHTS array.
 265           weights_(1)=wsc
 266           weights_(2)=wscp
 267           weights_(3)=welec
 268           weights_(4)=wcorr
 269           weights_(5)=wcorr5
 270           weights_(6)=wcorr6
 271           weights_(7)=wel_loc
 272           weights_(8)=wturn3
 273           weights_(9)=wturn4
 274           weights_(10)=wturn6
 275           weights_(11)=wang
 276           weights_(12)=wscloc
 277           weights_(13)=wtor
 278           weights_(14)=wtor_d
 279           weights_(15)=wstrain
 280           weights_(16)=wvdwpp
 281           weights_(17)=wbond
 282           weights_(18)=scal14
 283           weights_(21)=wsccor
 284           weights_(26)=wvdwpp_nucl
 285           weights_(27)=welpp
 286           weights_(28)=wvdwpsb
 287           weights_(29)=welpsb
 288           weights_(30)=wvdwsb
 289           weights_(31)=welsb
 290           weights_(32)=wbond_nucl
 291           weights_(33)=wang_nucl
 292           weights_(34)=wsbloc
 293           weights_(35)=wtor_nucl
 294           weights_(36)=wtor_d_nucl
 295           weights_(37)=wcorr_nucl
 296           weights_(38)=wcorr3_nucl
 297           weights(41)=wcatcat
 298           weights(42)=wcatprot
 299 !          wcatcat= weights(41)
 300 !          wcatprot=weights(42)
 301
 302 ! FG Master broadcasts the WEIGHTS_ array
 303           call MPI_Bcast(weights_(1),n_ene,&
 304              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 305         else
 306 ! FG slaves receive the WEIGHTS array
 307           call MPI_Bcast(weights(1),n_ene,&
 308               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 309           wsc=weights(1)
 310           wscp=weights(2)
 311           welec=weights(3)
 312           wcorr=weights(4)
 313           wcorr5=weights(5)
 314           wcorr6=weights(6)
 315           wel_loc=weights(7)
 316           wturn3=weights(8)
 317           wturn4=weights(9)
 318           wturn6=weights(10)
 319           wang=weights(11)
 320           wscloc=weights(12)
 321           wtor=weights(13)
 322           wtor_d=weights(14)
 323           wstrain=weights(15)
 324           wvdwpp=weights(16)
 325           wbond=weights(17)
 326           scal14=weights(18)
 327           wsccor=weights(21)
 328           wvdwpp_nucl =weights(26)
 329           welpp  =weights(27)
 330           wvdwpsb=weights(28)
 331           welpsb =weights(29)
 332           wvdwsb =weights(30)
 333           welsb  =weights(31)
 334           wbond_nucl  =weights(32)
 335           wang_nucl   =weights(33)
 336           wsbloc =weights(34)
 337           wtor_nucl   =weights(35)
 338           wtor_d_nucl =weights(36)
 339           wcorr_nucl  =weights(37)
 340           wcorr3_nucl =weights(38)
 341           wcatcat= weights(41)
 342           wcatprot=weights(42)
 343         endif
 344         time_Bcast=time_Bcast+MPI_Wtime()-time00
 345         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 346 !        call chainbuild_cart
 347       endif
 348 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 349 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 350 #else
 351 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 352 !        call int_from_cart1(.false.)
 353 !      endif
 354 #endif
 355 #ifdef TIMING
 356       time00=MPI_Wtime()
 357 #endif
 358 !
 359 ! Compute the side-chain and electrostatic interaction energy
 360 !        print *, "Before EVDW"
 361 !      goto (101,102,103,104,105,106) ipot
 362       select case(ipot)
 363 ! Lennard-Jones potential.
 364 !  101 call elj(evdw)
 365        case (1)
 366          call elj(evdw)
 367 !d    print '(a)','Exit ELJcall el'
 368 !      goto 107
 369 ! Lennard-Jones-Kihara potential (shifted).
 370 !  102 call eljk(evdw)
 371        case (2)
 372          call eljk(evdw)
 373 !      goto 107
 374 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 375 !  103 call ebp(evdw)
 376        case (3)
 377          call ebp(evdw)
 378 !      goto 107
 379 ! Gay-Berne potential (shifted LJ, angular dependence).
 380 !  104 call egb(evdw)
 381        case (4)
 382          call egb(evdw)
 383 !      goto 107
 384 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 385 !  105 call egbv(evdw)
 386        case (5)
 387          call egbv(evdw)
 388 !      goto 107
 389 ! Soft-sphere potential
 390 !  106 call e_softsphere(evdw)
 391        case (6)
 392          call e_softsphere(evdw)
 393 !
 394 ! Calculate electrostatic (H-bonding) energy of the main chain.
 395 !
 396 !  107 continue
 397        case default
 398          write(iout,*)"Wrong ipot"
 399 !         return
 400 !   50 continue
 401       end select
 402 !      continue
 403 !        print *,"after EGB"
 404 ! shielding effect
 405        if (shield_mode.eq.2) then
 406                  call set_shield_fac2
 407        endif
 408 !       print *,"AFTER EGB",ipot,evdw
 409 !mc
 410 !mc Sep-06: egb takes care of dynamic ss bonds too
 411 !mc
 412 !      if (dyn_ss) call dyn_set_nss
 413 !      print *,"Processor",myrank," computed USCSC"
 414 #ifdef TIMING
 415       time01=MPI_Wtime()
 416 #endif
 417       call vec_and_deriv
 418 #ifdef TIMING
 419       time_vec=time_vec+MPI_Wtime()-time01
 420 #endif
 421 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 422       if (ipot.lt.6) then
 423 #ifdef SPLITELE
 424 !         print *,"after ipot if", ipot
 425          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 426              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 427              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 428              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 429 #else
 430          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 431              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 432              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 433              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 434 #endif
 435 !            print *,"just befor eelec call"
 436             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 437 !         write (iout,*) "ELEC calc"
 438          else
 439             ees=0.0d0
 440             evdw1=0.0d0
 441             eel_loc=0.0d0
 442             eello_turn3=0.0d0
 443             eello_turn4=0.0d0
 444          endif
 445       else
 446 !        write (iout,*) "Soft-spheer ELEC potential"
 447         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 448          eello_turn4)
 449       endif
 450 !      print *,"Processor",myrank," computed UELEC"
 451 !
 452 ! Calculate excluded-volume interaction energy between peptide groups
 453 ! and side chains.
 454 !
 455 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 456
 457       if (ipot.lt.6) then
 458        if(wscp.gt.0d0) then
 459         call escp(evdw2,evdw2_14)
 460        else
 461         evdw2=0
 462         evdw2_14=0
 463        endif
 464       else
 465 !        write (iout,*) "Soft-sphere SCP potential"
 466         call escp_soft_sphere(evdw2,evdw2_14)
 467       endif
 468 !       write(iout,*) "in etotal before ebond",ipot
 469
 470 !
 471 ! Calculate the bond-stretching energy
 472 !
 473       call ebond(estr)
 474 !       print *,"EBOND",estr
 475 !       write(iout,*) "in etotal afer ebond",ipot
 476
 477 !
 478 ! Calculate the disulfide-bridge and other energy and the contributions
 479 ! from other distance constraints.
 480 !      print *,'Calling EHPB'
 481       call edis(ehpb)
 482 !elwrite(iout,*) "in etotal afer edis",ipot
 483 !      print *,'EHPB exitted succesfully.'
 484 !
 485 ! Calculate the virtual-bond-angle energy.
 486 !
 487       if (wang.gt.0d0) then
 488         call ebend(ebe,ethetacnstr)
 489       else
 490         ebe=0
 491         ethetacnstr=0
 492       endif
 493 !      print *,"Processor",myrank," computed UB"
 494 !
 495 ! Calculate the SC local energy.
 496 !
 497       call esc(escloc)
 498 !elwrite(iout,*) "in etotal afer esc",ipot
 499 !      print *,"Processor",myrank," computed USC"
 500 !
 501 ! Calculate the virtual-bond torsional energy.
 502 !
 503 !d    print *,'nterm=',nterm
 504       if (wtor.gt.0) then
 505        call etor(etors,edihcnstr)
 506       else
 507        etors=0
 508        edihcnstr=0
 509       endif
 510 !      print *,"Processor",myrank," computed Utor"
 511 !
 512 ! 6/23/01 Calculate double-torsional energy
 513 !
 514 !elwrite(iout,*) "in etotal",ipot
 515       if (wtor_d.gt.0) then
 516        call etor_d(etors_d)
 517       else
 518        etors_d=0
 519       endif
 520 !      print *,"Processor",myrank," computed Utord"
 521 !
 522 ! 21/5/07 Calculate local sicdechain correlation energy
 523 !
 524       if (wsccor.gt.0.0d0) then
 525         call eback_sc_corr(esccor)
 526       else
 527         esccor=0.0d0
 528       endif
 529 !      print *,"Processor",myrank," computed Usccorr"
 530 !
 531 ! 12/1/95 Multi-body terms
 532 !
 533       n_corr=0
 534       n_corr1=0
 535       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 536           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 537          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 538 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 539 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 540       else
 541          ecorr=0.0d0
 542          ecorr5=0.0d0
 543          ecorr6=0.0d0
 544          eturn6=0.0d0
 545       endif
 546 !elwrite(iout,*) "in etotal",ipot
 547       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 548          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 549 !d         write (iout,*) "multibody_hb ecorr",ecorr
 550       endif
 551 !elwrite(iout,*) "afeter  multibody hb"
 552
 553 !      print *,"Processor",myrank," computed Ucorr"
 554 !
 555 ! If performing constraint dynamics, call the constraint energy
 556 !  after the equilibration time
 557       if(usampl.and.totT.gt.eq_time) then
 558 !elwrite(iout,*) "afeter  multibody hb"
 559          call EconstrQ
 560 !elwrite(iout,*) "afeter  multibody hb"
 561          call Econstr_back
 562 !elwrite(iout,*) "afeter  multibody hb"
 563       else
 564          Uconst=0.0d0
 565          Uconst_back=0.0d0
 566       endif
 567       call flush(iout)
 568 !         write(iout,*) "after Econstr"
 569
 570       if (wliptran.gt.0) then
 571 !        print *,"PRZED WYWOLANIEM"
 572         call Eliptransfer(eliptran)
 573       else
 574        eliptran=0.0d0
 575       endif
 576       if (fg_rank.eq.0) then
 577       if (AFMlog.gt.0) then
 578         call AFMforce(Eafmforce)
 579       else if (selfguide.gt.0) then
 580         call AFMvel(Eafmforce)
 581       endif
 582       endif
 583       if (tubemode.eq.1) then
 584        call calctube(etube)
 585       else if (tubemode.eq.2) then
 586        call calctube2(etube)
 587       elseif (tubemode.eq.3) then
 588        call calcnano(etube)
 589       else
 590        etube=0.0d0
 591       endif
 592 !--------------------------------------------------------
 593 !      print *,"before",ees,evdw1,ecorr
 594       call ebond_nucl(estr_nucl)
 595       call ebend_nucl(ebe_nucl)
 596       call etor_nucl(etors_nucl)
 597       call esb_gb(evdwsb,eelsb)
 598       call epp_nucl_sub(evdwpp,eespp)
 599       call epsb(evdwpsb,eelpsb)
 600       call esb(esbloc)
 601       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 602       call ecatcat(ecationcation)
 603       call ecat_prot(ecation_prot)
 604 !      call ecatcat(ecationcation)
 605 !      print *,"after ebend", ebe_nucl
 606 #ifdef TIMING
 607       time_enecalc=time_enecalc+MPI_Wtime()-time00
 608 #endif
 609 !      print *,"Processor",myrank," computed Uconstr"
 610 #ifdef TIMING
 611       time00=MPI_Wtime()
 612 #endif
 613 !
 614 ! Sum the energies
 615 !
 616       energia(1)=evdw
 617 #ifdef SCP14
 618       energia(2)=evdw2-evdw2_14
 619       energia(18)=evdw2_14
 620 #else
 621       energia(2)=evdw2
 622       energia(18)=0.0d0
 623 #endif
 624 #ifdef SPLITELE
 625       energia(3)=ees
 626       energia(16)=evdw1
 627 #else
 628       energia(3)=ees+evdw1
 629       energia(16)=0.0d0
 630 #endif
 631       energia(4)=ecorr
 632       energia(5)=ecorr5
 633       energia(6)=ecorr6
 634       energia(7)=eel_loc
 635       energia(8)=eello_turn3
 636       energia(9)=eello_turn4
 637       energia(10)=eturn6
 638       energia(11)=ebe
 639       energia(12)=escloc
 640       energia(13)=etors
 641       energia(14)=etors_d
 642       energia(15)=ehpb
 643       energia(19)=edihcnstr
 644       energia(17)=estr
 645       energia(20)=Uconst+Uconst_back
 646       energia(21)=esccor
 647       energia(22)=eliptran
 648       energia(23)=Eafmforce
 649       energia(24)=ethetacnstr
 650       energia(25)=etube
 651 !---------------------------------------------------------------
 652       energia(26)=evdwpp
 653       energia(27)=eespp
 654       energia(28)=evdwpsb
 655       energia(29)=eelpsb
 656       energia(30)=evdwsb
 657       energia(31)=eelsb
 658       energia(32)=estr_nucl
 659       energia(33)=ebe_nucl
 660       energia(34)=esbloc
 661       energia(35)=etors_nucl
 662       energia(36)=etors_d_nucl
 663       energia(37)=ecorr_nucl
 664       energia(38)=ecorr3_nucl
 665 !----------------------------------------------------------------------
 666 !    Here are the energies showed per procesor if the are more processors
 667 !    per molecule then we sum it up in sum_energy subroutine
 668 !      print *," Processor",myrank," calls SUM_ENERGY"
 669       energia(41)=ecation_prot
 670       energia(42)=ecationcation
 671       call sum_energy(energia,.true.)
 672       if (dyn_ss) call dyn_set_nss
 673 !      print *," Processor",myrank," left SUM_ENERGY"
 674 #ifdef TIMING
 675       time_sumene=time_sumene+MPI_Wtime()-time00
 676 #endif
 677 !el        call enerprint(energia)
 678 !elwrite(iout,*)"finish etotal"
 679       return
 680       end subroutine etotal
 681 !-----------------------------------------------------------------------------
 682       subroutine sum_energy(energia,reduce)
 683 !      implicit real*8 (a-h,o-z)
 684 !      include 'DIMENSIONS'
 685 #ifndef ISNAN
 686       external proc_proc
 687 #ifdef WINPGI
 688 !MS$ATTRIBUTES C ::  proc_proc
 689 #endif
 690 #endif
 691 #ifdef MPI
 692       include "mpif.h"
 693 #endif
 694 !      include 'COMMON.SETUP'
 695 !      include 'COMMON.IOUNITS'
 696       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 697 !      include 'COMMON.FFIELD'
 698 !      include 'COMMON.DERIV'
 699 !      include 'COMMON.INTERACT'
 700 !      include 'COMMON.SBRIDGE'
 701 !      include 'COMMON.CHAIN'
 702 !      include 'COMMON.VAR'
 703 !      include 'COMMON.CONTROL'
 704 !      include 'COMMON.TIME1'
 705       logical :: reduce
 706       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 707       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 708       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 709         eliptran,etube, Eafmforce,ethetacnstr
 710       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 711                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 712                       ecorr3_nucl
 713       real(kind=8) :: ecation_prot,ecationcation
 714       integer :: i
 715 #ifdef MPI
 716       integer :: ierr
 717       real(kind=8) :: time00
 718       if (nfgtasks.gt.1 .and. reduce) then
 719
 720 #ifdef DEBUG
 721         write (iout,*) "energies before REDUCE"
 722         call enerprint(energia)
 723         call flush(iout)
 724 #endif
 725         do i=0,n_ene
 726           enebuff(i)=energia(i)
 727         enddo
 728         time00=MPI_Wtime()
 729         call MPI_Barrier(FG_COMM,IERR)
 730         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 731         time00=MPI_Wtime()
 732         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 733           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 734 #ifdef DEBUG
 735         write (iout,*) "energies after REDUCE"
 736         call enerprint(energia)
 737         call flush(iout)
 738 #endif
 739         time_Reduce=time_Reduce+MPI_Wtime()-time00
 740       endif
 741       if (fg_rank.eq.0) then
 742 #endif
 743       evdw=energia(1)
 744 #ifdef SCP14
 745       evdw2=energia(2)+energia(18)
 746       evdw2_14=energia(18)
 747 #else
 748       evdw2=energia(2)
 749 #endif
 750 #ifdef SPLITELE
 751       ees=energia(3)
 752       evdw1=energia(16)
 753 #else
 754       ees=energia(3)
 755       evdw1=0.0d0
 756 #endif
 757       ecorr=energia(4)
 758       ecorr5=energia(5)
 759       ecorr6=energia(6)
 760       eel_loc=energia(7)
 761       eello_turn3=energia(8)
 762       eello_turn4=energia(9)
 763       eturn6=energia(10)
 764       ebe=energia(11)
 765       escloc=energia(12)
 766       etors=energia(13)
 767       etors_d=energia(14)
 768       ehpb=energia(15)
 769       edihcnstr=energia(19)
 770       estr=energia(17)
 771       Uconst=energia(20)
 772       esccor=energia(21)
 773       eliptran=energia(22)
 774       Eafmforce=energia(23)
 775       ethetacnstr=energia(24)
 776       etube=energia(25)
 777       evdwpp=energia(26)
 778       eespp=energia(27)
 779       evdwpsb=energia(28)
 780       eelpsb=energia(29)
 781       evdwsb=energia(30)
 782       eelsb=energia(31)
 783       estr_nucl=energia(32)
 784       ebe_nucl=energia(33)
 785       esbloc=energia(34)
 786       etors_nucl=energia(35)
 787       etors_d_nucl=energia(36)
 788       ecorr_nucl=energia(37)
 789       ecorr3_nucl=energia(38)
 790       ecation_prot=energia(41)
 791       ecationcation=energia(42)
 792 !      energia(41)=ecation_prot
 793 !      energia(42)=ecationcation
 794
 795
 796 #ifdef SPLITELE
 797       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 798        +wang*ebe+wtor*etors+wscloc*escloc &
 799        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 800        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 801        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 802        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 803        +Eafmforce+ethetacnstr  &
 804        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 805        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 806        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 807        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 808        +wcatprot*ecation_prot+wcatcat*ecationcation
 809 #else
 810       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 811        +wang*ebe+wtor*etors+wscloc*escloc &
 812        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 813        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 814        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 815        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 816        +Eafmforce+ethetacnstr &
 817        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 818        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 819        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 820        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 821        +wcatprot*ecation_prot+wcatcat*ecationcation
 822 #endif
 823       energia(0)=etot
 824 ! detecting NaNQ
 825 #ifdef ISNAN
 826 #ifdef AIX
 827       if (isnan(etot).ne.0) energia(0)=1.0d+99
 828 #else
 829       if (isnan(etot)) energia(0)=1.0d+99
 830 #endif
 831 #else
 832       i=0
 833 #ifdef WINPGI
 834       idumm=proc_proc(etot,i)
 835 #else
 836       call proc_proc(etot,i)
 837 #endif
 838       if(i.eq.1)energia(0)=1.0d+99
 839 #endif
 840 #ifdef MPI
 841       endif
 842 #endif
 843 !      call enerprint(energia)
 844       call flush(iout)
 845       return
 846       end subroutine sum_energy
 847 !-----------------------------------------------------------------------------
 848       subroutine rescale_weights(t_bath)
 849 !      implicit real*8 (a-h,o-z)
 850 #ifdef MPI
 851       include 'mpif.h'
 852 #endif
 853 !      include 'DIMENSIONS'
 854 !      include 'COMMON.IOUNITS'
 855 !      include 'COMMON.FFIELD'
 856 !      include 'COMMON.SBRIDGE'
 857       real(kind=8) :: kfac=2.4d0
 858       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 859 !el local variables
 860       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 861       real(kind=8) :: T0=3.0d2
 862       integer :: ierror
 863 !      facT=temp0/t_bath
 864 !      facT=2*temp0/(t_bath+temp0)
 865       if (rescale_mode.eq.0) then
 866         facT(1)=1.0d0
 867         facT(2)=1.0d0
 868         facT(3)=1.0d0
 869         facT(4)=1.0d0
 870         facT(5)=1.0d0
 871         facT(6)=1.0d0
 872       else if (rescale_mode.eq.1) then
 873         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 874         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 875         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 876         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 877         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 878 #ifdef WHAM_RUN
 879 !#if defined(WHAM_RUN) || defined(CLUSTER)
 880 #if defined(FUNCTH)
 881 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 882         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 883 #elif defined(FUNCT)
 884         facT(6)=t_bath/T0
 885 #else
 886         facT(6)=1.0d0
 887 #endif
 888 #endif
 889       else if (rescale_mode.eq.2) then
 890         x=t_bath/temp0
 891         x2=x*x
 892         x3=x2*x
 893         x4=x3*x
 894         x5=x4*x
 895         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 896         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 897         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 898         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 899         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 900 #ifdef WHAM_RUN
 901 !#if defined(WHAM_RUN) || defined(CLUSTER)
 902 #if defined(FUNCTH)
 903         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 904 #elif defined(FUNCT)
 905         facT(6)=t_bath/T0
 906 #else
 907         facT(6)=1.0d0
 908 #endif
 909 #endif
 910       else
 911         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 912         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 913 #ifdef MPI
 914        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 915 #endif
 916        stop 555
 917       endif
 918       welec=weights(3)*fact(1)
 919       wcorr=weights(4)*fact(3)
 920       wcorr5=weights(5)*fact(4)
 921       wcorr6=weights(6)*fact(5)
 922       wel_loc=weights(7)*fact(2)
 923       wturn3=weights(8)*fact(2)
 924       wturn4=weights(9)*fact(3)
 925       wturn6=weights(10)*fact(5)
 926       wtor=weights(13)*fact(1)
 927       wtor_d=weights(14)*fact(2)
 928       wsccor=weights(21)*fact(1)
 929
 930       return
 931       end subroutine rescale_weights
 932 !-----------------------------------------------------------------------------
 933       subroutine enerprint(energia)
 934 !      implicit real*8 (a-h,o-z)
 935 !      include 'DIMENSIONS'
 936 !      include 'COMMON.IOUNITS'
 937 !      include 'COMMON.FFIELD'
 938 !      include 'COMMON.SBRIDGE'
 939 !      include 'COMMON.MD'
 940       real(kind=8) :: energia(0:n_ene)
 941 !el local variables
 942       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 943       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 944       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
 945        etube,ethetacnstr,Eafmforce
 946       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 947                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 948                       ecorr3_nucl
 949       real(kind=8) :: ecation_prot,ecationcation
 950
 951       etot=energia(0)
 952       evdw=energia(1)
 953       evdw2=energia(2)
 954 #ifdef SCP14
 955       evdw2=energia(2)+energia(18)
 956 #else
 957       evdw2=energia(2)
 958 #endif
 959       ees=energia(3)
 960 #ifdef SPLITELE
 961       evdw1=energia(16)
 962 #endif
 963       ecorr=energia(4)
 964       ecorr5=energia(5)
 965       ecorr6=energia(6)
 966       eel_loc=energia(7)
 967       eello_turn3=energia(8)
 968       eello_turn4=energia(9)
 969       eello_turn6=energia(10)
 970       ebe=energia(11)
 971       escloc=energia(12)
 972       etors=energia(13)
 973       etors_d=energia(14)
 974       ehpb=energia(15)
 975       edihcnstr=energia(19)
 976       estr=energia(17)
 977       Uconst=energia(20)
 978       esccor=energia(21)
 979       eliptran=energia(22)
 980       Eafmforce=energia(23)
 981       ethetacnstr=energia(24)
 982       etube=energia(25)
 983       evdwpp=energia(26)
 984       eespp=energia(27)
 985       evdwpsb=energia(28)
 986       eelpsb=energia(29)
 987       evdwsb=energia(30)
 988       eelsb=energia(31)
 989       estr_nucl=energia(32)
 990       ebe_nucl=energia(33)
 991       esbloc=energia(34)
 992       etors_nucl=energia(35)
 993       etors_d_nucl=energia(36)
 994       ecorr_nucl=energia(37)
 995       ecorr3_nucl=energia(38)
 996       ecation_prot=energia(41)
 997       ecationcation=energia(42)
 998
 999 #ifdef SPLITELE
1000       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1001         estr,wbond,ebe,wang,&
1002         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1003         ecorr,wcorr,&
1004         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1005         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1006         edihcnstr,ethetacnstr,ebr*nss,&
1007         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1008         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1009         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1010         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1011         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1012         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1013         etot
1014    10 format (/'Virtual-chain energies:'// &
1015        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1016        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1017        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1018        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1019        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1020        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1021        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1022        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1023        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1024        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1025        ' (SS bridges & dist. cnstr.)'/ &
1026        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1027        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1028        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1029        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1030        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1031        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1032        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1033        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1034        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1035        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1036        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1037        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1038        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1039        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1040        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1041        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1042        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1043        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1044        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1045        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1046        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1047        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1048        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1049        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1050        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1051        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1052        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1053        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1054        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1055        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1056        'ETOT=  ',1pE16.6,' (total)')
1057 #else
1058       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1059         estr,wbond,ebe,wang,&
1060         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1061         ecorr,wcorr,&
1062         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1063         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1064         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
1065         etube,wtube, &
1066         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1067         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1068         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1069         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1070         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1071         etot
1072    10 format (/'Virtual-chain energies:'// &
1073        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1074        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1075        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1076        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1077        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1078        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1079        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1080        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1081        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1082        ' (SS bridges & dist. cnstr.)'/ &
1083        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1084        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1085        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1086        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1087        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1088        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1089        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1090        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1091        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1092        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1093        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1094        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1095        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1096        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1097        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1098        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1099        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1100        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1101        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1102        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1103        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1104        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1105        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1106        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1107        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1108        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1109        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1110        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1111        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1112        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1113        'ETOT=  ',1pE16.6,' (total)')
1114 #endif
1115       return
1116       end subroutine enerprint
1117 !-----------------------------------------------------------------------------
1118       subroutine elj(evdw)
1119 !
1120 ! This subroutine calculates the interaction energy of nonbonded side chains
1121 ! assuming the LJ potential of interaction.
1122 !
1123 !      implicit real*8 (a-h,o-z)
1124 !      include 'DIMENSIONS'
1125       real(kind=8),parameter :: accur=1.0d-10
1126 !      include 'COMMON.GEO'
1127 !      include 'COMMON.VAR'
1128 !      include 'COMMON.LOCAL'
1129 !      include 'COMMON.CHAIN'
1130 !      include 'COMMON.DERIV'
1131 !      include 'COMMON.INTERACT'
1132 !      include 'COMMON.TORSION'
1133 !      include 'COMMON.SBRIDGE'
1134 !      include 'COMMON.NAMES'
1135 !      include 'COMMON.IOUNITS'
1136 !      include 'COMMON.CONTACTS'
1137       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1138       integer :: num_conti
1139 !el local variables
1140       integer :: i,itypi,iint,j,itypi1,itypj,k
1141       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1142       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1143       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1144
1145 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1146       evdw=0.0D0
1147 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1148 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1149 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1150 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1151
1152       do i=iatsc_s,iatsc_e
1153         itypi=iabs(itype(i,1))
1154         if (itypi.eq.ntyp1) cycle
1155         itypi1=iabs(itype(i+1,1))
1156         xi=c(1,nres+i)
1157         yi=c(2,nres+i)
1158         zi=c(3,nres+i)
1159 ! Change 12/1/95
1160         num_conti=0
1161 !
1162 ! Calculate SC interaction energy.
1163 !
1164         do iint=1,nint_gr(i)
1165 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1166 !d   &                  'iend=',iend(i,iint)
1167           do j=istart(i,iint),iend(i,iint)
1168             itypj=iabs(itype(j,1))
1169             if (itypj.eq.ntyp1) cycle
1170             xj=c(1,nres+j)-xi
1171             yj=c(2,nres+j)-yi
1172             zj=c(3,nres+j)-zi
1173 ! Change 12/1/95 to calculate four-body interactions
1174             rij=xj*xj+yj*yj+zj*zj
1175             rrij=1.0D0/rij
1176 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1177             eps0ij=eps(itypi,itypj)
1178             fac=rrij**expon2
1179             e1=fac*fac*aa_aq(itypi,itypj)
1180             e2=fac*bb_aq(itypi,itypj)
1181             evdwij=e1+e2
1182 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1183 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1184 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1185 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1186 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1187 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1188             evdw=evdw+evdwij
1189 !
1190 ! Calculate the components of the gradient in DC and X
1191 !
1192             fac=-rrij*(e1+evdwij)
1193             gg(1)=xj*fac
1194             gg(2)=yj*fac
1195             gg(3)=zj*fac
1196             do k=1,3
1197               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1198               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1199               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1200               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1201             enddo
1202 !grad            do k=i,j-1
1203 !grad              do l=1,3
1204 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1205 !grad              enddo
1206 !grad            enddo
1207 !
1208 ! 12/1/95, revised on 5/20/97
1209 !
1210 ! Calculate the contact function. The ith column of the array JCONT will
1211 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1212 ! greater than I). The arrays FACONT and GACONT will contain the values of
1213 ! the contact function and its derivative.
1214 !
1215 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1216 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1217 ! Uncomment next line, if the correlation interactions are contact function only
1218             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1219               rij=dsqrt(rij)
1220               sigij=sigma(itypi,itypj)
1221               r0ij=rs0(itypi,itypj)
1222 !
1223 ! Check whether the SC's are not too far to make a contact.
1224 !
1225               rcut=1.5d0*r0ij
1226               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1227 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1228 !
1229               if (fcont.gt.0.0D0) then
1230 ! If the SC-SC distance if close to sigma, apply spline.
1231 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1232 !Adam &             fcont1,fprimcont1)
1233 !Adam           fcont1=1.0d0-fcont1
1234 !Adam           if (fcont1.gt.0.0d0) then
1235 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1236 !Adam             fcont=fcont*fcont1
1237 !Adam           endif
1238 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1239 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1240 !ga             do k=1,3
1241 !ga               gg(k)=gg(k)*eps0ij
1242 !ga             enddo
1243 !ga             eps0ij=-evdwij*eps0ij
1244 ! Uncomment for AL's type of SC correlation interactions.
1245 !adam           eps0ij=-evdwij
1246                 num_conti=num_conti+1
1247                 jcont(num_conti,i)=j
1248                 facont(num_conti,i)=fcont*eps0ij
1249                 fprimcont=eps0ij*fprimcont/rij
1250                 fcont=expon*fcont
1251 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1252 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1253 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1254 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1255                 gacont(1,num_conti,i)=-fprimcont*xj
1256                 gacont(2,num_conti,i)=-fprimcont*yj
1257                 gacont(3,num_conti,i)=-fprimcont*zj
1258 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1259 !d              write (iout,'(2i3,3f10.5)')
1260 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1261               endif
1262             endif
1263           enddo      ! j
1264         enddo        ! iint
1265 ! Change 12/1/95
1266         num_cont(i)=num_conti
1267       enddo          ! i
1268       do i=1,nct
1269         do j=1,3
1270           gvdwc(j,i)=expon*gvdwc(j,i)
1271           gvdwx(j,i)=expon*gvdwx(j,i)
1272         enddo
1273       enddo
1274 !******************************************************************************
1275 !
1276 !                              N O T E !!!
1277 !
1278 ! To save time, the factor of EXPON has been extracted from ALL components
1279 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1280 ! use!
1281 !
1282 !******************************************************************************
1283       return
1284       end subroutine elj
1285 !-----------------------------------------------------------------------------
1286       subroutine eljk(evdw)
1287 !
1288 ! This subroutine calculates the interaction energy of nonbonded side chains
1289 ! assuming the LJK potential of interaction.
1290 !
1291 !      implicit real*8 (a-h,o-z)
1292 !      include 'DIMENSIONS'
1293 !      include 'COMMON.GEO'
1294 !      include 'COMMON.VAR'
1295 !      include 'COMMON.LOCAL'
1296 !      include 'COMMON.CHAIN'
1297 !      include 'COMMON.DERIV'
1298 !      include 'COMMON.INTERACT'
1299 !      include 'COMMON.IOUNITS'
1300 !      include 'COMMON.NAMES'
1301       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1302       logical :: scheck
1303 !el local variables
1304       integer :: i,iint,j,itypi,itypi1,k,itypj
1305       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1306       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1307
1308 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1309       evdw=0.0D0
1310       do i=iatsc_s,iatsc_e
1311         itypi=iabs(itype(i,1))
1312         if (itypi.eq.ntyp1) cycle
1313         itypi1=iabs(itype(i+1,1))
1314         xi=c(1,nres+i)
1315         yi=c(2,nres+i)
1316         zi=c(3,nres+i)
1317 !
1318 ! Calculate SC interaction energy.
1319 !
1320         do iint=1,nint_gr(i)
1321           do j=istart(i,iint),iend(i,iint)
1322             itypj=iabs(itype(j,1))
1323             if (itypj.eq.ntyp1) cycle
1324             xj=c(1,nres+j)-xi
1325             yj=c(2,nres+j)-yi
1326             zj=c(3,nres+j)-zi
1327             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1328             fac_augm=rrij**expon
1329             e_augm=augm(itypi,itypj)*fac_augm
1330             r_inv_ij=dsqrt(rrij)
1331             rij=1.0D0/r_inv_ij
1332             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1333             fac=r_shift_inv**expon
1334             e1=fac*fac*aa_aq(itypi,itypj)
1335             e2=fac*bb_aq(itypi,itypj)
1336             evdwij=e_augm+e1+e2
1337 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1338 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1339 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1340 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1341 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1342 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1343 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1344             evdw=evdw+evdwij
1345 !
1346 ! Calculate the components of the gradient in DC and X
1347 !
1348             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1349             gg(1)=xj*fac
1350             gg(2)=yj*fac
1351             gg(3)=zj*fac
1352             do k=1,3
1353               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1354               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1355               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1356               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1357             enddo
1358 !grad            do k=i,j-1
1359 !grad              do l=1,3
1360 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1361 !grad              enddo
1362 !grad            enddo
1363           enddo      ! j
1364         enddo        ! iint
1365       enddo          ! i
1366       do i=1,nct
1367         do j=1,3
1368           gvdwc(j,i)=expon*gvdwc(j,i)
1369           gvdwx(j,i)=expon*gvdwx(j,i)
1370         enddo
1371       enddo
1372       return
1373       end subroutine eljk
1374 !-----------------------------------------------------------------------------
1375       subroutine ebp(evdw)
1376 !
1377 ! This subroutine calculates the interaction energy of nonbonded side chains
1378 ! assuming the Berne-Pechukas potential of interaction.
1379 !
1380       use comm_srutu
1381       use calc_data
1382 !      implicit real*8 (a-h,o-z)
1383 !      include 'DIMENSIONS'
1384 !      include 'COMMON.GEO'
1385 !      include 'COMMON.VAR'
1386 !      include 'COMMON.LOCAL'
1387 !      include 'COMMON.CHAIN'
1388 !      include 'COMMON.DERIV'
1389 !      include 'COMMON.NAMES'
1390 !      include 'COMMON.INTERACT'
1391 !      include 'COMMON.IOUNITS'
1392 !      include 'COMMON.CALC'
1393       use comm_srutu
1394 !el      integer :: icall
1395 !el      common /srutu/ icall
1396 !     double precision rrsave(maxdim)
1397       logical :: lprn
1398 !el local variables
1399       integer :: iint,itypi,itypi1,itypj
1400       real(kind=8) :: rrij,xi,yi,zi
1401       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1402
1403 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1404       evdw=0.0D0
1405 !     if (icall.eq.0) then
1406 !       lprn=.true.
1407 !     else
1408         lprn=.false.
1409 !     endif
1410 !el      ind=0
1411       do i=iatsc_s,iatsc_e
1412         itypi=iabs(itype(i,1))
1413         if (itypi.eq.ntyp1) cycle
1414         itypi1=iabs(itype(i+1,1))
1415         xi=c(1,nres+i)
1416         yi=c(2,nres+i)
1417         zi=c(3,nres+i)
1418         dxi=dc_norm(1,nres+i)
1419         dyi=dc_norm(2,nres+i)
1420         dzi=dc_norm(3,nres+i)
1421 !        dsci_inv=dsc_inv(itypi)
1422         dsci_inv=vbld_inv(i+nres)
1423 !
1424 ! Calculate SC interaction energy.
1425 !
1426         do iint=1,nint_gr(i)
1427           do j=istart(i,iint),iend(i,iint)
1428 !el            ind=ind+1
1429             itypj=iabs(itype(j,1))
1430             if (itypj.eq.ntyp1) cycle
1431 !            dscj_inv=dsc_inv(itypj)
1432             dscj_inv=vbld_inv(j+nres)
1433             chi1=chi(itypi,itypj)
1434             chi2=chi(itypj,itypi)
1435             chi12=chi1*chi2
1436             chip1=chip(itypi)
1437             chip2=chip(itypj)
1438             chip12=chip1*chip2
1439             alf1=alp(itypi)
1440             alf2=alp(itypj)
1441             alf12=0.5D0*(alf1+alf2)
1442 ! For diagnostics only!!!
1443 !           chi1=0.0D0
1444 !           chi2=0.0D0
1445 !           chi12=0.0D0
1446 !           chip1=0.0D0
1447 !           chip2=0.0D0
1448 !           chip12=0.0D0
1449 !           alf1=0.0D0
1450 !           alf2=0.0D0
1451 !           alf12=0.0D0
1452             xj=c(1,nres+j)-xi
1453             yj=c(2,nres+j)-yi
1454             zj=c(3,nres+j)-zi
1455             dxj=dc_norm(1,nres+j)
1456             dyj=dc_norm(2,nres+j)
1457             dzj=dc_norm(3,nres+j)
1458             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1459 !d          if (icall.eq.0) then
1460 !d            rrsave(ind)=rrij
1461 !d          else
1462 !d            rrij=rrsave(ind)
1463 !d          endif
1464             rij=dsqrt(rrij)
1465 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1466             call sc_angular
1467 ! Calculate whole angle-dependent part of epsilon and contributions
1468 ! to its derivatives
1469             fac=(rrij*sigsq)**expon2
1470             e1=fac*fac*aa_aq(itypi,itypj)
1471             e2=fac*bb_aq(itypi,itypj)
1472             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1473             eps2der=evdwij*eps3rt
1474             eps3der=evdwij*eps2rt
1475             evdwij=evdwij*eps2rt*eps3rt
1476             evdw=evdw+evdwij
1477             if (lprn) then
1478             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1479             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1480 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1481 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1482 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1483 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1484 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1485 !d     &        evdwij
1486             endif
1487 ! Calculate gradient components.
1488             e1=e1*eps1*eps2rt**2*eps3rt**2
1489             fac=-expon*(e1+evdwij)
1490             sigder=fac/sigsq
1491             fac=rrij*fac
1492 ! Calculate radial part of the gradient
1493             gg(1)=xj*fac
1494             gg(2)=yj*fac
1495             gg(3)=zj*fac
1496 ! Calculate the angular part of the gradient and sum add the contributions
1497 ! to the appropriate components of the Cartesian gradient.
1498             call sc_grad
1499           enddo      ! j
1500         enddo        ! iint
1501       enddo          ! i
1502 !     stop
1503       return
1504       end subroutine ebp
1505 !-----------------------------------------------------------------------------
1506       subroutine egb(evdw)
1507 !
1508 ! This subroutine calculates the interaction energy of nonbonded side chains
1509 ! assuming the Gay-Berne potential of interaction.
1510 !
1511       use calc_data
1512 !      implicit real*8 (a-h,o-z)
1513 !      include 'DIMENSIONS'
1514 !      include 'COMMON.GEO'
1515 !      include 'COMMON.VAR'
1516 !      include 'COMMON.LOCAL'
1517 !      include 'COMMON.CHAIN'
1518 !      include 'COMMON.DERIV'
1519 !      include 'COMMON.NAMES'
1520 !      include 'COMMON.INTERACT'
1521 !      include 'COMMON.IOUNITS'
1522 !      include 'COMMON.CALC'
1523 !      include 'COMMON.CONTROL'
1524 !      include 'COMMON.SBRIDGE'
1525       logical :: lprn
1526 !el local variables
1527       integer :: iint,itypi,itypi1,itypj,subchap
1528       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1529       real(kind=8) :: evdw,sig0ij
1530       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1531                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1532                     sslipi,sslipj,faclip
1533       integer :: ii
1534       real(kind=8) :: fracinbuf
1535
1536 !cccc      energy_dec=.false.
1537 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1538       evdw=0.0D0
1539       lprn=.false.
1540 !     if (icall.eq.0) lprn=.false.
1541 !el      ind=0
1542       do i=iatsc_s,iatsc_e
1543 !C        print *,"I am in EVDW",i
1544         itypi=iabs(itype(i,1))
1545 !        if (i.ne.47) cycle
1546         if (itypi.eq.ntyp1) cycle
1547         itypi1=iabs(itype(i+1,1))
1548         xi=c(1,nres+i)
1549         yi=c(2,nres+i)
1550         zi=c(3,nres+i)
1551           xi=dmod(xi,boxxsize)
1552           if (xi.lt.0) xi=xi+boxxsize
1553           yi=dmod(yi,boxysize)
1554           if (yi.lt.0) yi=yi+boxysize
1555           zi=dmod(zi,boxzsize)
1556           if (zi.lt.0) zi=zi+boxzsize
1557
1558        if ((zi.gt.bordlipbot)  &
1559         .and.(zi.lt.bordliptop)) then
1560 !C the energy transfer exist
1561         if (zi.lt.buflipbot) then
1562 !C what fraction I am in
1563          fracinbuf=1.0d0-  &
1564               ((zi-bordlipbot)/lipbufthick)
1565 !C lipbufthick is thickenes of lipid buffore
1566          sslipi=sscalelip(fracinbuf)
1567          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1568         elseif (zi.gt.bufliptop) then
1569          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1570          sslipi=sscalelip(fracinbuf)
1571          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1572         else
1573          sslipi=1.0d0
1574          ssgradlipi=0.0
1575         endif
1576        else
1577          sslipi=0.0d0
1578          ssgradlipi=0.0
1579        endif
1580 !       print *, sslipi,ssgradlipi
1581         dxi=dc_norm(1,nres+i)
1582         dyi=dc_norm(2,nres+i)
1583         dzi=dc_norm(3,nres+i)
1584 !        dsci_inv=dsc_inv(itypi)
1585         dsci_inv=vbld_inv(i+nres)
1586 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1587 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1588 !
1589 ! Calculate SC interaction energy.
1590 !
1591         do iint=1,nint_gr(i)
1592           do j=istart(i,iint),iend(i,iint)
1593             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1594               call dyn_ssbond_ene(i,j,evdwij)
1595               evdw=evdw+evdwij
1596               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1597                               'evdw',i,j,evdwij,' ss'
1598 !              if (energy_dec) write (iout,*) &
1599 !                              'evdw',i,j,evdwij,' ss'
1600              do k=j+1,iend(i,iint)
1601 !C search over all next residues
1602               if (dyn_ss_mask(k)) then
1603 !C check if they are cysteins
1604 !C              write(iout,*) 'k=',k
1605
1606 !c              write(iout,*) "PRZED TRI", evdwij
1607 !               evdwij_przed_tri=evdwij
1608               call triple_ssbond_ene(i,j,k,evdwij)
1609 !c               if(evdwij_przed_tri.ne.evdwij) then
1610 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1611 !c               endif
1612
1613 !c              write(iout,*) "PO TRI", evdwij
1614 !C call the energy function that removes the artifical triple disulfide
1615 !C bond the soubroutine is located in ssMD.F
1616               evdw=evdw+evdwij
1617               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1618                             'evdw',i,j,evdwij,'tss'
1619               endif!dyn_ss_mask(k)
1620              enddo! k
1621             ELSE
1622 !el            ind=ind+1
1623             itypj=iabs(itype(j,1))
1624             if (itypj.eq.ntyp1) cycle
1625 !             if (j.ne.78) cycle
1626 !            dscj_inv=dsc_inv(itypj)
1627             dscj_inv=vbld_inv(j+nres)
1628 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1629 !              1.0d0/vbld(j+nres) !d
1630 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1631             sig0ij=sigma(itypi,itypj)
1632             chi1=chi(itypi,itypj)
1633             chi2=chi(itypj,itypi)
1634             chi12=chi1*chi2
1635             chip1=chip(itypi)
1636             chip2=chip(itypj)
1637             chip12=chip1*chip2
1638             alf1=alp(itypi)
1639             alf2=alp(itypj)
1640             alf12=0.5D0*(alf1+alf2)
1641 ! For diagnostics only!!!
1642 !           chi1=0.0D0
1643 !           chi2=0.0D0
1644 !           chi12=0.0D0
1645 !           chip1=0.0D0
1646 !           chip2=0.0D0
1647 !           chip12=0.0D0
1648 !           alf1=0.0D0
1649 !           alf2=0.0D0
1650 !           alf12=0.0D0
1651            xj=c(1,nres+j)
1652            yj=c(2,nres+j)
1653            zj=c(3,nres+j)
1654           xj=dmod(xj,boxxsize)
1655           if (xj.lt.0) xj=xj+boxxsize
1656           yj=dmod(yj,boxysize)
1657           if (yj.lt.0) yj=yj+boxysize
1658           zj=dmod(zj,boxzsize)
1659           if (zj.lt.0) zj=zj+boxzsize
1660 !          print *,"tu",xi,yi,zi,xj,yj,zj
1661 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1662 ! this fragment set correct epsilon for lipid phase
1663        if ((zj.gt.bordlipbot)  &
1664        .and.(zj.lt.bordliptop)) then
1665 !C the energy transfer exist
1666         if (zj.lt.buflipbot) then
1667 !C what fraction I am in
1668          fracinbuf=1.0d0-     &
1669              ((zj-bordlipbot)/lipbufthick)
1670 !C lipbufthick is thickenes of lipid buffore
1671          sslipj=sscalelip(fracinbuf)
1672          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1673         elseif (zj.gt.bufliptop) then
1674          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1675          sslipj=sscalelip(fracinbuf)
1676          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1677         else
1678          sslipj=1.0d0
1679          ssgradlipj=0.0
1680         endif
1681        else
1682          sslipj=0.0d0
1683          ssgradlipj=0.0
1684        endif
1685       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1686        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1687       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1688        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1689 !------------------------------------------------
1690       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1691       xj_safe=xj
1692       yj_safe=yj
1693       zj_safe=zj
1694       subchap=0
1695       do xshift=-1,1
1696       do yshift=-1,1
1697       do zshift=-1,1
1698           xj=xj_safe+xshift*boxxsize
1699           yj=yj_safe+yshift*boxysize
1700           zj=zj_safe+zshift*boxzsize
1701           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1702           if(dist_temp.lt.dist_init) then
1703             dist_init=dist_temp
1704             xj_temp=xj
1705             yj_temp=yj
1706             zj_temp=zj
1707             subchap=1
1708           endif
1709        enddo
1710        enddo
1711        enddo
1712        if (subchap.eq.1) then
1713           xj=xj_temp-xi
1714           yj=yj_temp-yi
1715           zj=zj_temp-zi
1716        else
1717           xj=xj_safe-xi
1718           yj=yj_safe-yi
1719           zj=zj_safe-zi
1720        endif
1721             dxj=dc_norm(1,nres+j)
1722             dyj=dc_norm(2,nres+j)
1723             dzj=dc_norm(3,nres+j)
1724 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1725 !            write (iout,*) "j",j," dc_norm",& !d
1726 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1727 !          write(iout,*)"rrij ",rrij
1728 !          write(iout,*)"xj yj zj ", xj, yj, zj
1729 !          write(iout,*)"xi yi zi ", xi, yi, zi
1730 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1731             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1732             rij=dsqrt(rrij)
1733             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1734             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1735 !            print *,sss_ele_cut,sss_ele_grad,&
1736 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1737             if (sss_ele_cut.le.0.0) cycle
1738 ! Calculate angle-dependent terms of energy and contributions to their
1739 ! derivatives.
1740             call sc_angular
1741             sigsq=1.0D0/sigsq
1742             sig=sig0ij*dsqrt(sigsq)
1743             rij_shift=1.0D0/rij-sig+sig0ij
1744 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1745 !            "sig0ij",sig0ij
1746 ! for diagnostics; uncomment
1747 !            rij_shift=1.2*sig0ij
1748 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1749             if (rij_shift.le.0.0D0) then
1750               evdw=1.0D20
1751 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1752 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1753 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1754               return
1755             endif
1756             sigder=-sig*sigsq
1757 !---------------------------------------------------------------
1758             rij_shift=1.0D0/rij_shift
1759             fac=rij_shift**expon
1760             faclip=fac
1761             e1=fac*fac*aa!(itypi,itypj)
1762             e2=fac*bb!(itypi,itypj)
1763             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1764             eps2der=evdwij*eps3rt
1765             eps3der=evdwij*eps2rt
1766 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1767 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1768 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1769             evdwij=evdwij*eps2rt*eps3rt
1770             evdw=evdw+evdwij*sss_ele_cut
1771             if (lprn) then
1772             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1773             epsi=bb**2/aa!(itypi,itypj)
1774             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1775               restyp(itypi,1),i,restyp(itypj,1),j, &
1776               epsi,sigm,chi1,chi2,chip1,chip2, &
1777               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1778               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1779               evdwij
1780             endif
1781
1782             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1783                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1784 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1785 !            if (energy_dec) write (iout,*) &
1786 !                             'evdw',i,j,evdwij
1787 !                       print *,"ZALAMKA", evdw
1788
1789 ! Calculate gradient components.
1790             e1=e1*eps1*eps2rt**2*eps3rt**2
1791             fac=-expon*(e1+evdwij)*rij_shift
1792             sigder=fac*sigder
1793             fac=rij*fac
1794 !            print *,'before fac',fac,rij,evdwij
1795             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1796             /sigma(itypi,itypj)*rij
1797 !            print *,'grad part scale',fac,   &
1798 !             evdwij*sss_ele_grad/sss_ele_cut &
1799 !            /sigma(itypi,itypj)*rij
1800 !            fac=0.0d0
1801 ! Calculate the radial part of the gradient
1802             gg(1)=xj*fac
1803             gg(2)=yj*fac
1804             gg(3)=zj*fac
1805 !C Calculate the radial part of the gradient
1806             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1807        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1808         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1809        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1810             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1811             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1812
1813 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1814 ! Calculate angular part of the gradient.
1815             call sc_grad
1816             ENDIF    ! dyn_ss
1817           enddo      ! j
1818         enddo        ! iint
1819       enddo          ! i
1820 !       print *,"ZALAMKA", evdw
1821 !      write (iout,*) "Number of loop steps in EGB:",ind
1822 !ccc      energy_dec=.false.
1823       return
1824       end subroutine egb
1825 !-----------------------------------------------------------------------------
1826       subroutine egbv(evdw)
1827 !
1828 ! This subroutine calculates the interaction energy of nonbonded side chains
1829 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1830 !
1831       use comm_srutu
1832       use calc_data
1833 !      implicit real*8 (a-h,o-z)
1834 !      include 'DIMENSIONS'
1835 !      include 'COMMON.GEO'
1836 !      include 'COMMON.VAR'
1837 !      include 'COMMON.LOCAL'
1838 !      include 'COMMON.CHAIN'
1839 !      include 'COMMON.DERIV'
1840 !      include 'COMMON.NAMES'
1841 !      include 'COMMON.INTERACT'
1842 !      include 'COMMON.IOUNITS'
1843 !      include 'COMMON.CALC'
1844       use comm_srutu
1845 !el      integer :: icall
1846 !el      common /srutu/ icall
1847       logical :: lprn
1848 !el local variables
1849       integer :: iint,itypi,itypi1,itypj
1850       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1851       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1852
1853 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1854       evdw=0.0D0
1855       lprn=.false.
1856 !     if (icall.eq.0) lprn=.true.
1857 !el      ind=0
1858       do i=iatsc_s,iatsc_e
1859         itypi=iabs(itype(i,1))
1860         if (itypi.eq.ntyp1) cycle
1861         itypi1=iabs(itype(i+1,1))
1862         xi=c(1,nres+i)
1863         yi=c(2,nres+i)
1864         zi=c(3,nres+i)
1865         dxi=dc_norm(1,nres+i)
1866         dyi=dc_norm(2,nres+i)
1867         dzi=dc_norm(3,nres+i)
1868 !        dsci_inv=dsc_inv(itypi)
1869         dsci_inv=vbld_inv(i+nres)
1870 !
1871 ! Calculate SC interaction energy.
1872 !
1873         do iint=1,nint_gr(i)
1874           do j=istart(i,iint),iend(i,iint)
1875 !el            ind=ind+1
1876             itypj=iabs(itype(j,1))
1877             if (itypj.eq.ntyp1) cycle
1878 !            dscj_inv=dsc_inv(itypj)
1879             dscj_inv=vbld_inv(j+nres)
1880             sig0ij=sigma(itypi,itypj)
1881             r0ij=r0(itypi,itypj)
1882             chi1=chi(itypi,itypj)
1883             chi2=chi(itypj,itypi)
1884             chi12=chi1*chi2
1885             chip1=chip(itypi)
1886             chip2=chip(itypj)
1887             chip12=chip1*chip2
1888             alf1=alp(itypi)
1889             alf2=alp(itypj)
1890             alf12=0.5D0*(alf1+alf2)
1891 ! For diagnostics only!!!
1892 !           chi1=0.0D0
1893 !           chi2=0.0D0
1894 !           chi12=0.0D0
1895 !           chip1=0.0D0
1896 !           chip2=0.0D0
1897 !           chip12=0.0D0
1898 !           alf1=0.0D0
1899 !           alf2=0.0D0
1900 !           alf12=0.0D0
1901             xj=c(1,nres+j)-xi
1902             yj=c(2,nres+j)-yi
1903             zj=c(3,nres+j)-zi
1904             dxj=dc_norm(1,nres+j)
1905             dyj=dc_norm(2,nres+j)
1906             dzj=dc_norm(3,nres+j)
1907             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1908             rij=dsqrt(rrij)
1909 ! Calculate angle-dependent terms of energy and contributions to their
1910 ! derivatives.
1911             call sc_angular
1912             sigsq=1.0D0/sigsq
1913             sig=sig0ij*dsqrt(sigsq)
1914             rij_shift=1.0D0/rij-sig+r0ij
1915 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1916             if (rij_shift.le.0.0D0) then
1917               evdw=1.0D20
1918               return
1919             endif
1920             sigder=-sig*sigsq
1921 !---------------------------------------------------------------
1922             rij_shift=1.0D0/rij_shift
1923             fac=rij_shift**expon
1924             e1=fac*fac*aa_aq(itypi,itypj)
1925             e2=fac*bb_aq(itypi,itypj)
1926             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1927             eps2der=evdwij*eps3rt
1928             eps3der=evdwij*eps2rt
1929             fac_augm=rrij**expon
1930             e_augm=augm(itypi,itypj)*fac_augm
1931             evdwij=evdwij*eps2rt*eps3rt
1932             evdw=evdw+evdwij+e_augm
1933             if (lprn) then
1934             sigm=dabs(aa_aq(itypi,itypj)/&
1935             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1936             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1937             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1938               restyp(itypi,1),i,restyp(itypj,1),j,&
1939               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1940               chi1,chi2,chip1,chip2,&
1941               eps1,eps2rt**2,eps3rt**2,&
1942               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1943               evdwij+e_augm
1944             endif
1945 ! Calculate gradient components.
1946             e1=e1*eps1*eps2rt**2*eps3rt**2
1947             fac=-expon*(e1+evdwij)*rij_shift
1948             sigder=fac*sigder
1949             fac=rij*fac-2*expon*rrij*e_augm
1950 ! Calculate the radial part of the gradient
1951             gg(1)=xj*fac
1952             gg(2)=yj*fac
1953             gg(3)=zj*fac
1954 ! Calculate angular part of the gradient.
1955             call sc_grad
1956           enddo      ! j
1957         enddo        ! iint
1958       enddo          ! i
1959       end subroutine egbv
1960 !-----------------------------------------------------------------------------
1961 !el      subroutine sc_angular in module geometry
1962 !-----------------------------------------------------------------------------
1963       subroutine e_softsphere(evdw)
1964 !
1965 ! This subroutine calculates the interaction energy of nonbonded side chains
1966 ! assuming the LJ potential of interaction.
1967 !
1968 !      implicit real*8 (a-h,o-z)
1969 !      include 'DIMENSIONS'
1970       real(kind=8),parameter :: accur=1.0d-10
1971 !      include 'COMMON.GEO'
1972 !      include 'COMMON.VAR'
1973 !      include 'COMMON.LOCAL'
1974 !      include 'COMMON.CHAIN'
1975 !      include 'COMMON.DERIV'
1976 !      include 'COMMON.INTERACT'
1977 !      include 'COMMON.TORSION'
1978 !      include 'COMMON.SBRIDGE'
1979 !      include 'COMMON.NAMES'
1980 !      include 'COMMON.IOUNITS'
1981 !      include 'COMMON.CONTACTS'
1982       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1983 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1984 !el local variables
1985       integer :: i,iint,j,itypi,itypi1,itypj,k
1986       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1987       real(kind=8) :: fac
1988
1989       evdw=0.0D0
1990       do i=iatsc_s,iatsc_e
1991         itypi=iabs(itype(i,1))
1992         if (itypi.eq.ntyp1) cycle
1993         itypi1=iabs(itype(i+1,1))
1994         xi=c(1,nres+i)
1995         yi=c(2,nres+i)
1996         zi=c(3,nres+i)
1997 !
1998 ! Calculate SC interaction energy.
1999 !
2000         do iint=1,nint_gr(i)
2001 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2002 !d   &                  'iend=',iend(i,iint)
2003           do j=istart(i,iint),iend(i,iint)
2004             itypj=iabs(itype(j,1))
2005             if (itypj.eq.ntyp1) cycle
2006             xj=c(1,nres+j)-xi
2007             yj=c(2,nres+j)-yi
2008             zj=c(3,nres+j)-zi
2009             rij=xj*xj+yj*yj+zj*zj
2010 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2011             r0ij=r0(itypi,itypj)
2012             r0ijsq=r0ij*r0ij
2013 !            print *,i,j,r0ij,dsqrt(rij)
2014             if (rij.lt.r0ijsq) then
2015               evdwij=0.25d0*(rij-r0ijsq)**2
2016               fac=rij-r0ijsq
2017             else
2018               evdwij=0.0d0
2019               fac=0.0d0
2020             endif
2021             evdw=evdw+evdwij
2022 !
2023 ! Calculate the components of the gradient in DC and X
2024 !
2025             gg(1)=xj*fac
2026             gg(2)=yj*fac
2027             gg(3)=zj*fac
2028             do k=1,3
2029               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2030               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2031               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2032               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2033             enddo
2034 !grad            do k=i,j-1
2035 !grad              do l=1,3
2036 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2037 !grad              enddo
2038 !grad            enddo
2039           enddo ! j
2040         enddo ! iint
2041       enddo ! i
2042       return
2043       end subroutine e_softsphere
2044 !-----------------------------------------------------------------------------
2045       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2046 !
2047 ! Soft-sphere potential of p-p interaction
2048 !
2049 !      implicit real*8 (a-h,o-z)
2050 !      include 'DIMENSIONS'
2051 !      include 'COMMON.CONTROL'
2052 !      include 'COMMON.IOUNITS'
2053 !      include 'COMMON.GEO'
2054 !      include 'COMMON.VAR'
2055 !      include 'COMMON.LOCAL'
2056 !      include 'COMMON.CHAIN'
2057 !      include 'COMMON.DERIV'
2058 !      include 'COMMON.INTERACT'
2059 !      include 'COMMON.CONTACTS'
2060 !      include 'COMMON.TORSION'
2061 !      include 'COMMON.VECTORS'
2062 !      include 'COMMON.FFIELD'
2063       real(kind=8),dimension(3) :: ggg
2064 !d      write(iout,*) 'In EELEC_soft_sphere'
2065 !el local variables
2066       integer :: i,j,k,num_conti,iteli,itelj
2067       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2068       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2069       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2070
2071       ees=0.0D0
2072       evdw1=0.0D0
2073       eel_loc=0.0d0
2074       eello_turn3=0.0d0
2075       eello_turn4=0.0d0
2076 !el      ind=0
2077       do i=iatel_s,iatel_e
2078         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2079         dxi=dc(1,i)
2080         dyi=dc(2,i)
2081         dzi=dc(3,i)
2082         xmedi=c(1,i)+0.5d0*dxi
2083         ymedi=c(2,i)+0.5d0*dyi
2084         zmedi=c(3,i)+0.5d0*dzi
2085         num_conti=0
2086 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2087         do j=ielstart(i),ielend(i)
2088           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2089 !el          ind=ind+1
2090           iteli=itel(i)
2091           itelj=itel(j)
2092           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2093           r0ij=rpp(iteli,itelj)
2094           r0ijsq=r0ij*r0ij
2095           dxj=dc(1,j)
2096           dyj=dc(2,j)
2097           dzj=dc(3,j)
2098           xj=c(1,j)+0.5D0*dxj-xmedi
2099           yj=c(2,j)+0.5D0*dyj-ymedi
2100           zj=c(3,j)+0.5D0*dzj-zmedi
2101           rij=xj*xj+yj*yj+zj*zj
2102           if (rij.lt.r0ijsq) then
2103             evdw1ij=0.25d0*(rij-r0ijsq)**2
2104             fac=rij-r0ijsq
2105           else
2106             evdw1ij=0.0d0
2107             fac=0.0d0
2108           endif
2109           evdw1=evdw1+evdw1ij
2110 !
2111 ! Calculate contributions to the Cartesian gradient.
2112 !
2113           ggg(1)=fac*xj
2114           ggg(2)=fac*yj
2115           ggg(3)=fac*zj
2116           do k=1,3
2117             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2118             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2119           enddo
2120 !
2121 ! Loop over residues i+1 thru j-1.
2122 !
2123 !grad          do k=i+1,j-1
2124 !grad            do l=1,3
2125 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2126 !grad            enddo
2127 !grad          enddo
2128         enddo ! j
2129       enddo   ! i
2130 !grad      do i=nnt,nct-1
2131 !grad        do k=1,3
2132 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2133 !grad        enddo
2134 !grad        do j=i+1,nct-1
2135 !grad          do k=1,3
2136 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2137 !grad          enddo
2138 !grad        enddo
2139 !grad      enddo
2140       return
2141       end subroutine eelec_soft_sphere
2142 !-----------------------------------------------------------------------------
2143       subroutine vec_and_deriv
2144 !      implicit real*8 (a-h,o-z)
2145 !      include 'DIMENSIONS'
2146 #ifdef MPI
2147       include 'mpif.h'
2148 #endif
2149 !      include 'COMMON.IOUNITS'
2150 !      include 'COMMON.GEO'
2151 !      include 'COMMON.VAR'
2152 !      include 'COMMON.LOCAL'
2153 !      include 'COMMON.CHAIN'
2154 !      include 'COMMON.VECTORS'
2155 !      include 'COMMON.SETUP'
2156 !      include 'COMMON.TIME1'
2157       real(kind=8),dimension(3,3,2) :: uyder,uzder
2158       real(kind=8),dimension(2) :: vbld_inv_temp
2159 ! Compute the local reference systems. For reference system (i), the
2160 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2161 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2162 !el local variables
2163       integer :: i,j,k,l
2164       real(kind=8) :: facy,fac,costh
2165
2166 #ifdef PARVEC
2167       do i=ivec_start,ivec_end
2168 #else
2169       do i=1,nres-1
2170 #endif
2171           if (i.eq.nres-1) then
2172 ! Case of the last full residue
2173 ! Compute the Z-axis
2174             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2175             costh=dcos(pi-theta(nres))
2176             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2177             do k=1,3
2178               uz(k,i)=fac*uz(k,i)
2179             enddo
2180 ! Compute the derivatives of uz
2181             uzder(1,1,1)= 0.0d0
2182             uzder(2,1,1)=-dc_norm(3,i-1)
2183             uzder(3,1,1)= dc_norm(2,i-1)
2184             uzder(1,2,1)= dc_norm(3,i-1)
2185             uzder(2,2,1)= 0.0d0
2186             uzder(3,2,1)=-dc_norm(1,i-1)
2187             uzder(1,3,1)=-dc_norm(2,i-1)
2188             uzder(2,3,1)= dc_norm(1,i-1)
2189             uzder(3,3,1)= 0.0d0
2190             uzder(1,1,2)= 0.0d0
2191             uzder(2,1,2)= dc_norm(3,i)
2192             uzder(3,1,2)=-dc_norm(2,i)
2193             uzder(1,2,2)=-dc_norm(3,i)
2194             uzder(2,2,2)= 0.0d0
2195             uzder(3,2,2)= dc_norm(1,i)
2196             uzder(1,3,2)= dc_norm(2,i)
2197             uzder(2,3,2)=-dc_norm(1,i)
2198             uzder(3,3,2)= 0.0d0
2199 ! Compute the Y-axis
2200             facy=fac
2201             do k=1,3
2202               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2203             enddo
2204 ! Compute the derivatives of uy
2205             do j=1,3
2206               do k=1,3
2207                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2208                               -dc_norm(k,i)*dc_norm(j,i-1)
2209                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2210               enddo
2211               uyder(j,j,1)=uyder(j,j,1)-costh
2212               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2213             enddo
2214             do j=1,2
2215               do k=1,3
2216                 do l=1,3
2217                   uygrad(l,k,j,i)=uyder(l,k,j)
2218                   uzgrad(l,k,j,i)=uzder(l,k,j)
2219                 enddo
2220               enddo
2221             enddo
2222             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2223             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2224             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2225             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2226           else
2227 ! Other residues
2228 ! Compute the Z-axis
2229             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2230             costh=dcos(pi-theta(i+2))
2231             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2232             do k=1,3
2233               uz(k,i)=fac*uz(k,i)
2234             enddo
2235 ! Compute the derivatives of uz
2236             uzder(1,1,1)= 0.0d0
2237             uzder(2,1,1)=-dc_norm(3,i+1)
2238             uzder(3,1,1)= dc_norm(2,i+1)
2239             uzder(1,2,1)= dc_norm(3,i+1)
2240             uzder(2,2,1)= 0.0d0
2241             uzder(3,2,1)=-dc_norm(1,i+1)
2242             uzder(1,3,1)=-dc_norm(2,i+1)
2243             uzder(2,3,1)= dc_norm(1,i+1)
2244             uzder(3,3,1)= 0.0d0
2245             uzder(1,1,2)= 0.0d0
2246             uzder(2,1,2)= dc_norm(3,i)
2247             uzder(3,1,2)=-dc_norm(2,i)
2248             uzder(1,2,2)=-dc_norm(3,i)
2249             uzder(2,2,2)= 0.0d0
2250             uzder(3,2,2)= dc_norm(1,i)
2251             uzder(1,3,2)= dc_norm(2,i)
2252             uzder(2,3,2)=-dc_norm(1,i)
2253             uzder(3,3,2)= 0.0d0
2254 ! Compute the Y-axis
2255             facy=fac
2256             do k=1,3
2257               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2258             enddo
2259 ! Compute the derivatives of uy
2260             do j=1,3
2261               do k=1,3
2262                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2263                               -dc_norm(k,i)*dc_norm(j,i+1)
2264                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2265               enddo
2266               uyder(j,j,1)=uyder(j,j,1)-costh
2267               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2268             enddo
2269             do j=1,2
2270               do k=1,3
2271                 do l=1,3
2272                   uygrad(l,k,j,i)=uyder(l,k,j)
2273                   uzgrad(l,k,j,i)=uzder(l,k,j)
2274                 enddo
2275               enddo
2276             enddo
2277             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2278             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2279             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2280             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2281           endif
2282       enddo
2283       do i=1,nres-1
2284         vbld_inv_temp(1)=vbld_inv(i+1)
2285         if (i.lt.nres-1) then
2286           vbld_inv_temp(2)=vbld_inv(i+2)
2287           else
2288           vbld_inv_temp(2)=vbld_inv(i)
2289           endif
2290         do j=1,2
2291           do k=1,3
2292             do l=1,3
2293               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2294               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2295             enddo
2296           enddo
2297         enddo
2298       enddo
2299 #if defined(PARVEC) && defined(MPI)
2300       if (nfgtasks1.gt.1) then
2301         time00=MPI_Wtime()
2302 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2303 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2304 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2305         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2306          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2307          FG_COMM1,IERR)
2308         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2309          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2310          FG_COMM1,IERR)
2311         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2312          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2313          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2314         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2315          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2316          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2317         time_gather=time_gather+MPI_Wtime()-time00
2318       endif
2319 !      if (fg_rank.eq.0) then
2320 !        write (iout,*) "Arrays UY and UZ"
2321 !        do i=1,nres-1
2322 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2323 !     &     (uz(k,i),k=1,3)
2324 !        enddo
2325 !      endif
2326 #endif
2327       return
2328       end subroutine vec_and_deriv
2329 !-----------------------------------------------------------------------------
2330       subroutine check_vecgrad
2331 !      implicit real*8 (a-h,o-z)
2332 !      include 'DIMENSIONS'
2333 !      include 'COMMON.IOUNITS'
2334 !      include 'COMMON.GEO'
2335 !      include 'COMMON.VAR'
2336 !      include 'COMMON.LOCAL'
2337 !      include 'COMMON.CHAIN'
2338 !      include 'COMMON.VECTORS'
2339       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2340       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2341       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2342       real(kind=8),dimension(3) :: erij
2343       real(kind=8) :: delta=1.0d-7
2344 !el local variables
2345       integer :: i,j,k,l
2346
2347       call vec_and_deriv
2348 !d      do i=1,nres
2349 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2350 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2351 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2352 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2353 !d     &     (dc_norm(if90,i),if90=1,3)
2354 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2355 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2356 !d          write(iout,'(a)')
2357 !d      enddo
2358       do i=1,nres
2359         do j=1,2
2360           do k=1,3
2361             do l=1,3
2362               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2363               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2364             enddo
2365           enddo
2366         enddo
2367       enddo
2368       call vec_and_deriv
2369       do i=1,nres
2370         do j=1,3
2371           uyt(j,i)=uy(j,i)
2372           uzt(j,i)=uz(j,i)
2373         enddo
2374       enddo
2375       do i=1,nres
2376 !d        write (iout,*) 'i=',i
2377         do k=1,3
2378           erij(k)=dc_norm(k,i)
2379         enddo
2380         do j=1,3
2381           do k=1,3
2382             dc_norm(k,i)=erij(k)
2383           enddo
2384           dc_norm(j,i)=dc_norm(j,i)+delta
2385 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2386 !          do k=1,3
2387 !            dc_norm(k,i)=dc_norm(k,i)/fac
2388 !          enddo
2389 !          write (iout,*) (dc_norm(k,i),k=1,3)
2390 !          write (iout,*) (erij(k),k=1,3)
2391           call vec_and_deriv
2392           do k=1,3
2393             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2394             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2395             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2396             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2397           enddo
2398 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2399 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2400 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2401         enddo
2402         do k=1,3
2403           dc_norm(k,i)=erij(k)
2404         enddo
2405 !d        do k=1,3
2406 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2407 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2408 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2409 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2410 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2411 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2412 !d          write (iout,'(a)')
2413 !d        enddo
2414       enddo
2415       return
2416       end subroutine check_vecgrad
2417 !-----------------------------------------------------------------------------
2418       subroutine set_matrices
2419 !      implicit real*8 (a-h,o-z)
2420 !      include 'DIMENSIONS'
2421 #ifdef MPI
2422       include "mpif.h"
2423 !      include "COMMON.SETUP"
2424       integer :: IERR
2425       integer :: status(MPI_STATUS_SIZE)
2426 #endif
2427 !      include 'COMMON.IOUNITS'
2428 !      include 'COMMON.GEO'
2429 !      include 'COMMON.VAR'
2430 !      include 'COMMON.LOCAL'
2431 !      include 'COMMON.CHAIN'
2432 !      include 'COMMON.DERIV'
2433 !      include 'COMMON.INTERACT'
2434 !      include 'COMMON.CONTACTS'
2435 !      include 'COMMON.TORSION'
2436 !      include 'COMMON.VECTORS'
2437 !      include 'COMMON.FFIELD'
2438       real(kind=8) :: auxvec(2),auxmat(2,2)
2439       integer :: i,iti1,iti,k,l
2440       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2441 !       print *,"in set matrices"
2442 !
2443 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2444 ! to calculate the el-loc multibody terms of various order.
2445 !
2446 !AL el      mu=0.0d0
2447 #ifdef PARMAT
2448       do i=ivec_start+2,ivec_end+2
2449 #else
2450       do i=3,nres+1
2451 #endif
2452 !      print *,i,"i"
2453         if (i .lt. nres+1) then
2454           sin1=dsin(phi(i))
2455           cos1=dcos(phi(i))
2456           sintab(i-2)=sin1
2457           costab(i-2)=cos1
2458           obrot(1,i-2)=cos1
2459           obrot(2,i-2)=sin1
2460           sin2=dsin(2*phi(i))
2461           cos2=dcos(2*phi(i))
2462           sintab2(i-2)=sin2
2463           costab2(i-2)=cos2
2464           obrot2(1,i-2)=cos2
2465           obrot2(2,i-2)=sin2
2466           Ug(1,1,i-2)=-cos1
2467           Ug(1,2,i-2)=-sin1
2468           Ug(2,1,i-2)=-sin1
2469           Ug(2,2,i-2)= cos1
2470           Ug2(1,1,i-2)=-cos2
2471           Ug2(1,2,i-2)=-sin2
2472           Ug2(2,1,i-2)=-sin2
2473           Ug2(2,2,i-2)= cos2
2474         else
2475           costab(i-2)=1.0d0
2476           sintab(i-2)=0.0d0
2477           obrot(1,i-2)=1.0d0
2478           obrot(2,i-2)=0.0d0
2479           obrot2(1,i-2)=0.0d0
2480           obrot2(2,i-2)=0.0d0
2481           Ug(1,1,i-2)=1.0d0
2482           Ug(1,2,i-2)=0.0d0
2483           Ug(2,1,i-2)=0.0d0
2484           Ug(2,2,i-2)=1.0d0
2485           Ug2(1,1,i-2)=0.0d0
2486           Ug2(1,2,i-2)=0.0d0
2487           Ug2(2,1,i-2)=0.0d0
2488           Ug2(2,2,i-2)=0.0d0
2489         endif
2490         if (i .gt. 3 .and. i .lt. nres+1) then
2491           obrot_der(1,i-2)=-sin1
2492           obrot_der(2,i-2)= cos1
2493           Ugder(1,1,i-2)= sin1
2494           Ugder(1,2,i-2)=-cos1
2495           Ugder(2,1,i-2)=-cos1
2496           Ugder(2,2,i-2)=-sin1
2497           dwacos2=cos2+cos2
2498           dwasin2=sin2+sin2
2499           obrot2_der(1,i-2)=-dwasin2
2500           obrot2_der(2,i-2)= dwacos2
2501           Ug2der(1,1,i-2)= dwasin2
2502           Ug2der(1,2,i-2)=-dwacos2
2503           Ug2der(2,1,i-2)=-dwacos2
2504           Ug2der(2,2,i-2)=-dwasin2
2505         else
2506           obrot_der(1,i-2)=0.0d0
2507           obrot_der(2,i-2)=0.0d0
2508           Ugder(1,1,i-2)=0.0d0
2509           Ugder(1,2,i-2)=0.0d0
2510           Ugder(2,1,i-2)=0.0d0
2511           Ugder(2,2,i-2)=0.0d0
2512           obrot2_der(1,i-2)=0.0d0
2513           obrot2_der(2,i-2)=0.0d0
2514           Ug2der(1,1,i-2)=0.0d0
2515           Ug2der(1,2,i-2)=0.0d0
2516           Ug2der(2,1,i-2)=0.0d0
2517           Ug2der(2,2,i-2)=0.0d0
2518         endif
2519 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2520         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2521           iti = itortyp(itype(i-2,1))
2522         else
2523           iti=ntortyp+1
2524         endif
2525 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2526         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2527           iti1 = itortyp(itype(i-1,1))
2528         else
2529           iti1=ntortyp+1
2530         endif
2531 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2532 !d        write (iout,*) '*******i',i,' iti1',iti
2533 !d        write (iout,*) 'b1',b1(:,iti)
2534 !d        write (iout,*) 'b2',b2(:,iti)
2535 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2536 !        if (i .gt. iatel_s+2) then
2537         if (i .gt. nnt+2) then
2538           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2539           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2540           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2541           then
2542           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2543           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2544           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2545           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2546           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2547           endif
2548         else
2549           do k=1,2
2550             Ub2(k,i-2)=0.0d0
2551             Ctobr(k,i-2)=0.0d0
2552             Dtobr2(k,i-2)=0.0d0
2553             do l=1,2
2554               EUg(l,k,i-2)=0.0d0
2555               CUg(l,k,i-2)=0.0d0
2556               DUg(l,k,i-2)=0.0d0
2557               DtUg2(l,k,i-2)=0.0d0
2558             enddo
2559           enddo
2560         endif
2561         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2562         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2563         do k=1,2
2564           muder(k,i-2)=Ub2der(k,i-2)
2565         enddo
2566 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2567         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2568           if (itype(i-1,1).le.ntyp) then
2569             iti1 = itortyp(itype(i-1,1))
2570           else
2571             iti1=ntortyp+1
2572           endif
2573         else
2574           iti1=ntortyp+1
2575         endif
2576         do k=1,2
2577           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2578         enddo
2579 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2580 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2581 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2582 !d        write (iout,*) 'mu1',mu1(:,i-2)
2583 !d        write (iout,*) 'mu2',mu2(:,i-2)
2584         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2585         then
2586         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2587         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2588         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2589         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2590         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2591 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2592         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2593         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2594         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2595         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2596         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2597         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2598         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2599         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2600         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2601         endif
2602       enddo
2603 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2604 ! The order of matrices is from left to right.
2605       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2606       then
2607 !      do i=max0(ivec_start,2),ivec_end
2608       do i=2,nres-1
2609         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2610         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2611         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2612         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2613         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2614         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2615         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2616         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2617       enddo
2618       endif
2619 #if defined(MPI) && defined(PARMAT)
2620 #ifdef DEBUG
2621 !      if (fg_rank.eq.0) then
2622         write (iout,*) "Arrays UG and UGDER before GATHER"
2623         do i=1,nres-1
2624           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2625            ((ug(l,k,i),l=1,2),k=1,2),&
2626            ((ugder(l,k,i),l=1,2),k=1,2)
2627         enddo
2628         write (iout,*) "Arrays UG2 and UG2DER"
2629         do i=1,nres-1
2630           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2631            ((ug2(l,k,i),l=1,2),k=1,2),&
2632            ((ug2der(l,k,i),l=1,2),k=1,2)
2633         enddo
2634         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2635         do i=1,nres-1
2636           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2637            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2638            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2639         enddo
2640         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2641         do i=1,nres-1
2642           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2643            costab(i),sintab(i),costab2(i),sintab2(i)
2644         enddo
2645         write (iout,*) "Array MUDER"
2646         do i=1,nres-1
2647           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2648         enddo
2649 !      endif
2650 #endif
2651       if (nfgtasks.gt.1) then
2652         time00=MPI_Wtime()
2653 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2654 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2655 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2656 #ifdef MATGATHER
2657         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2658          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2659          FG_COMM1,IERR)
2660         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2661          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2662          FG_COMM1,IERR)
2663         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2664          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2665          FG_COMM1,IERR)
2666         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2667          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2668          FG_COMM1,IERR)
2669         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2670          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2671          FG_COMM1,IERR)
2672         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2673          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2674          FG_COMM1,IERR)
2675         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2676          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2677          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2678         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2679          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2680          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2681         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2682          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2683          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2684         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2685          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2686          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2687         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2688         then
2689         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2690          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2691          FG_COMM1,IERR)
2692         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2693          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2694          FG_COMM1,IERR)
2695         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2696          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2697          FG_COMM1,IERR)
2698        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2699          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2700          FG_COMM1,IERR)
2701         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2702          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2703          FG_COMM1,IERR)
2704         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2705          ivec_count(fg_rank1),&
2706          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2707          FG_COMM1,IERR)
2708         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2709          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2710          FG_COMM1,IERR)
2711         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2712          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2713          FG_COMM1,IERR)
2714         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2715          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2716          FG_COMM1,IERR)
2717         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2718          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2719          FG_COMM1,IERR)
2720         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2721          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2722          FG_COMM1,IERR)
2723         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2724          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2725          FG_COMM1,IERR)
2726         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2727          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2728          FG_COMM1,IERR)
2729         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2730          ivec_count(fg_rank1),&
2731          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2732          FG_COMM1,IERR)
2733         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2734          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2735          FG_COMM1,IERR)
2736        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2737          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2738          FG_COMM1,IERR)
2739         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2740          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2741          FG_COMM1,IERR)
2742        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2743          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2744          FG_COMM1,IERR)
2745         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2746          ivec_count(fg_rank1),&
2747          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2748          FG_COMM1,IERR)
2749         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2750          ivec_count(fg_rank1),&
2751          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2752          FG_COMM1,IERR)
2753         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2754          ivec_count(fg_rank1),&
2755          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2756          MPI_MAT2,FG_COMM1,IERR)
2757         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2758          ivec_count(fg_rank1),&
2759          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2760          MPI_MAT2,FG_COMM1,IERR)
2761         endif
2762 #else
2763 ! Passes matrix info through the ring
2764       isend=fg_rank1
2765       irecv=fg_rank1-1
2766       if (irecv.lt.0) irecv=nfgtasks1-1
2767       iprev=irecv
2768       inext=fg_rank1+1
2769       if (inext.ge.nfgtasks1) inext=0
2770       do i=1,nfgtasks1-1
2771 !        write (iout,*) "isend",isend," irecv",irecv
2772 !        call flush(iout)
2773         lensend=lentyp(isend)
2774         lenrecv=lentyp(irecv)
2775 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2776 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2777 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2778 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2779 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2780 !        write (iout,*) "Gather ROTAT1"
2781 !        call flush(iout)
2782 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2783 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2784 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2785 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2786 !        write (iout,*) "Gather ROTAT2"
2787 !        call flush(iout)
2788         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2789          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2790          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2791          iprev,4400+irecv,FG_COMM,status,IERR)
2792 !        write (iout,*) "Gather ROTAT_OLD"
2793 !        call flush(iout)
2794         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2795          MPI_PRECOMP11(lensend),inext,5500+isend,&
2796          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2797          iprev,5500+irecv,FG_COMM,status,IERR)
2798 !        write (iout,*) "Gather PRECOMP11"
2799 !        call flush(iout)
2800         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2801          MPI_PRECOMP12(lensend),inext,6600+isend,&
2802          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2803          iprev,6600+irecv,FG_COMM,status,IERR)
2804 !        write (iout,*) "Gather PRECOMP12"
2805 !        call flush(iout)
2806         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2807         then
2808         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2809          MPI_ROTAT2(lensend),inext,7700+isend,&
2810          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2811          iprev,7700+irecv,FG_COMM,status,IERR)
2812 !        write (iout,*) "Gather PRECOMP21"
2813 !        call flush(iout)
2814         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2815          MPI_PRECOMP22(lensend),inext,8800+isend,&
2816          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2817          iprev,8800+irecv,FG_COMM,status,IERR)
2818 !        write (iout,*) "Gather PRECOMP22"
2819 !        call flush(iout)
2820         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2821          MPI_PRECOMP23(lensend),inext,9900+isend,&
2822          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2823          MPI_PRECOMP23(lenrecv),&
2824          iprev,9900+irecv,FG_COMM,status,IERR)
2825 !        write (iout,*) "Gather PRECOMP23"
2826 !        call flush(iout)
2827         endif
2828         isend=irecv
2829         irecv=irecv-1
2830         if (irecv.lt.0) irecv=nfgtasks1-1
2831       enddo
2832 #endif
2833         time_gather=time_gather+MPI_Wtime()-time00
2834       endif
2835 #ifdef DEBUG
2836 !      if (fg_rank.eq.0) then
2837         write (iout,*) "Arrays UG and UGDER"
2838         do i=1,nres-1
2839           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2840            ((ug(l,k,i),l=1,2),k=1,2),&
2841            ((ugder(l,k,i),l=1,2),k=1,2)
2842         enddo
2843         write (iout,*) "Arrays UG2 and UG2DER"
2844         do i=1,nres-1
2845           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2846            ((ug2(l,k,i),l=1,2),k=1,2),&
2847            ((ug2der(l,k,i),l=1,2),k=1,2)
2848         enddo
2849         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2850         do i=1,nres-1
2851           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2852            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2853            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2854         enddo
2855         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2856         do i=1,nres-1
2857           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2858            costab(i),sintab(i),costab2(i),sintab2(i)
2859         enddo
2860         write (iout,*) "Array MUDER"
2861         do i=1,nres-1
2862           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2863         enddo
2864 !      endif
2865 #endif
2866 #endif
2867 !d      do i=1,nres
2868 !d        iti = itortyp(itype(i,1))
2869 !d        write (iout,*) i
2870 !d        do j=1,2
2871 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2872 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2873 !d        enddo
2874 !d      enddo
2875       return
2876       end subroutine set_matrices
2877 !-----------------------------------------------------------------------------
2878       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2879 !
2880 ! This subroutine calculates the average interaction energy and its gradient
2881 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2882 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2883 ! The potential depends both on the distance of peptide-group centers and on
2884 ! the orientation of the CA-CA virtual bonds.
2885 !
2886       use comm_locel
2887 !      implicit real*8 (a-h,o-z)
2888 #ifdef MPI
2889       include 'mpif.h'
2890 #endif
2891 !      include 'DIMENSIONS'
2892 !      include 'COMMON.CONTROL'
2893 !      include 'COMMON.SETUP'
2894 !      include 'COMMON.IOUNITS'
2895 !      include 'COMMON.GEO'
2896 !      include 'COMMON.VAR'
2897 !      include 'COMMON.LOCAL'
2898 !      include 'COMMON.CHAIN'
2899 !      include 'COMMON.DERIV'
2900 !      include 'COMMON.INTERACT'
2901 !      include 'COMMON.CONTACTS'
2902 !      include 'COMMON.TORSION'
2903 !      include 'COMMON.VECTORS'
2904 !      include 'COMMON.FFIELD'
2905 !      include 'COMMON.TIME1'
2906       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2907       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2908       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2909 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2910       real(kind=8),dimension(4) :: muij
2911 !el      integer :: num_conti,j1,j2
2912 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2913 !el        dz_normi,xmedi,ymedi,zmedi
2914
2915 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2916 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2917 !el          num_conti,j1,j2
2918
2919 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2920 #ifdef MOMENT
2921       real(kind=8) :: scal_el=1.0d0
2922 #else
2923       real(kind=8) :: scal_el=0.5d0
2924 #endif
2925 ! 12/13/98
2926 ! 13-go grudnia roku pamietnego...
2927       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2928                                              0.0d0,1.0d0,0.0d0,&
2929                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2930 !el local variables
2931       integer :: i,k,j
2932       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2933       real(kind=8) :: fac,t_eelecij,fracinbuf
2934
2935
2936 !d      write(iout,*) 'In EELEC'
2937 !        print *,"IN EELEC"
2938 !d      do i=1,nloctyp
2939 !d        write(iout,*) 'Type',i
2940 !d        write(iout,*) 'B1',B1(:,i)
2941 !d        write(iout,*) 'B2',B2(:,i)
2942 !d        write(iout,*) 'CC',CC(:,:,i)
2943 !d        write(iout,*) 'DD',DD(:,:,i)
2944 !d        write(iout,*) 'EE',EE(:,:,i)
2945 !d      enddo
2946 !d      call check_vecgrad
2947 !d      stop
2948 !      ees=0.0d0  !AS
2949 !      evdw1=0.0d0
2950 !      eel_loc=0.0d0
2951 !      eello_turn3=0.0d0
2952 !      eello_turn4=0.0d0
2953       t_eelecij=0.0d0
2954       ees=0.0D0
2955       evdw1=0.0D0
2956       eel_loc=0.0d0
2957       eello_turn3=0.0d0
2958       eello_turn4=0.0d0
2959 !
2960
2961       if (icheckgrad.eq.1) then
2962 !el
2963 !        do i=0,2*nres+2
2964 !          dc_norm(1,i)=0.0d0
2965 !          dc_norm(2,i)=0.0d0
2966 !          dc_norm(3,i)=0.0d0
2967 !        enddo
2968         do i=1,nres-1
2969           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2970           do k=1,3
2971             dc_norm(k,i)=dc(k,i)*fac
2972           enddo
2973 !          write (iout,*) 'i',i,' fac',fac
2974         enddo
2975       endif
2976 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
2977 !        wturn6
2978       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2979           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2980           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2981 !        call vec_and_deriv
2982 #ifdef TIMING
2983         time01=MPI_Wtime()
2984 #endif
2985 !        print *, "before set matrices"
2986         call set_matrices
2987 !        print *, "after set matrices"
2988
2989 #ifdef TIMING
2990         time_mat=time_mat+MPI_Wtime()-time01
2991 #endif
2992       endif
2993 !       print *, "after set matrices"
2994 !d      do i=1,nres-1
2995 !d        write (iout,*) 'i=',i
2996 !d        do k=1,3
2997 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2998 !d        enddo
2999 !d        do k=1,3
3000 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3001 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3002 !d        enddo
3003 !d      enddo
3004       t_eelecij=0.0d0
3005       ees=0.0D0
3006       evdw1=0.0D0
3007       eel_loc=0.0d0
3008       eello_turn3=0.0d0
3009       eello_turn4=0.0d0
3010 !el      ind=0
3011       do i=1,nres
3012         num_cont_hb(i)=0
3013       enddo
3014 !d      print '(a)','Enter EELEC'
3015 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3016 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3017 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3018       do i=1,nres
3019         gel_loc_loc(i)=0.0d0
3020         gcorr_loc(i)=0.0d0
3021       enddo
3022 !
3023 !
3024 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3025 !
3026 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3027 !
3028
3029
3030 !        print *,"before iturn3 loop"
3031       do i=iturn3_start,iturn3_end
3032         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3033         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3034         dxi=dc(1,i)
3035         dyi=dc(2,i)
3036         dzi=dc(3,i)
3037         dx_normi=dc_norm(1,i)
3038         dy_normi=dc_norm(2,i)
3039         dz_normi=dc_norm(3,i)
3040         xmedi=c(1,i)+0.5d0*dxi
3041         ymedi=c(2,i)+0.5d0*dyi
3042         zmedi=c(3,i)+0.5d0*dzi
3043           xmedi=dmod(xmedi,boxxsize)
3044           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3045           ymedi=dmod(ymedi,boxysize)
3046           if (ymedi.lt.0) ymedi=ymedi+boxysize
3047           zmedi=dmod(zmedi,boxzsize)
3048           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3049         num_conti=0
3050        if ((zmedi.gt.bordlipbot) &
3051         .and.(zmedi.lt.bordliptop)) then
3052 !C the energy transfer exist
3053         if (zmedi.lt.buflipbot) then
3054 !C what fraction I am in
3055          fracinbuf=1.0d0- &
3056                ((zmedi-bordlipbot)/lipbufthick)
3057 !C lipbufthick is thickenes of lipid buffore
3058          sslipi=sscalelip(fracinbuf)
3059          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3060         elseif (zmedi.gt.bufliptop) then
3061          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3062          sslipi=sscalelip(fracinbuf)
3063          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3064         else
3065          sslipi=1.0d0
3066          ssgradlipi=0.0
3067         endif
3068        else
3069          sslipi=0.0d0
3070          ssgradlipi=0.0
3071        endif
3072 !       print *,i,sslipi,ssgradlipi
3073        call eelecij(i,i+2,ees,evdw1,eel_loc)
3074         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3075         num_cont_hb(i)=num_conti
3076       enddo
3077       do i=iturn4_start,iturn4_end
3078         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3079           .or. itype(i+3,1).eq.ntyp1 &
3080           .or. itype(i+4,1).eq.ntyp1) cycle
3081         dxi=dc(1,i)
3082         dyi=dc(2,i)
3083         dzi=dc(3,i)
3084         dx_normi=dc_norm(1,i)
3085         dy_normi=dc_norm(2,i)
3086         dz_normi=dc_norm(3,i)
3087         xmedi=c(1,i)+0.5d0*dxi
3088         ymedi=c(2,i)+0.5d0*dyi
3089         zmedi=c(3,i)+0.5d0*dzi
3090           xmedi=dmod(xmedi,boxxsize)
3091           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3092           ymedi=dmod(ymedi,boxysize)
3093           if (ymedi.lt.0) ymedi=ymedi+boxysize
3094           zmedi=dmod(zmedi,boxzsize)
3095           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3096        if ((zmedi.gt.bordlipbot)  &
3097        .and.(zmedi.lt.bordliptop)) then
3098 !C the energy transfer exist
3099         if (zmedi.lt.buflipbot) then
3100 !C what fraction I am in
3101          fracinbuf=1.0d0- &
3102              ((zmedi-bordlipbot)/lipbufthick)
3103 !C lipbufthick is thickenes of lipid buffore
3104          sslipi=sscalelip(fracinbuf)
3105          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3106         elseif (zmedi.gt.bufliptop) then
3107          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3108          sslipi=sscalelip(fracinbuf)
3109          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3110         else
3111          sslipi=1.0d0
3112          ssgradlipi=0.0
3113         endif
3114        else
3115          sslipi=0.0d0
3116          ssgradlipi=0.0
3117        endif
3118
3119         num_conti=num_cont_hb(i)
3120         call eelecij(i,i+3,ees,evdw1,eel_loc)
3121         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3122          call eturn4(i,eello_turn4)
3123         num_cont_hb(i)=num_conti
3124       enddo   ! i
3125 !
3126 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3127 !
3128 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3129       do i=iatel_s,iatel_e
3130         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3131         dxi=dc(1,i)
3132         dyi=dc(2,i)
3133         dzi=dc(3,i)
3134         dx_normi=dc_norm(1,i)
3135         dy_normi=dc_norm(2,i)
3136         dz_normi=dc_norm(3,i)
3137         xmedi=c(1,i)+0.5d0*dxi
3138         ymedi=c(2,i)+0.5d0*dyi
3139         zmedi=c(3,i)+0.5d0*dzi
3140           xmedi=dmod(xmedi,boxxsize)
3141           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3142           ymedi=dmod(ymedi,boxysize)
3143           if (ymedi.lt.0) ymedi=ymedi+boxysize
3144           zmedi=dmod(zmedi,boxzsize)
3145           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3146        if ((zmedi.gt.bordlipbot)  &
3147         .and.(zmedi.lt.bordliptop)) then
3148 !C the energy transfer exist
3149         if (zmedi.lt.buflipbot) then
3150 !C what fraction I am in
3151          fracinbuf=1.0d0- &
3152              ((zmedi-bordlipbot)/lipbufthick)
3153 !C lipbufthick is thickenes of lipid buffore
3154          sslipi=sscalelip(fracinbuf)
3155          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3156         elseif (zmedi.gt.bufliptop) then
3157          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3158          sslipi=sscalelip(fracinbuf)
3159          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3160         else
3161          sslipi=1.0d0
3162          ssgradlipi=0.0
3163         endif
3164        else
3165          sslipi=0.0d0
3166          ssgradlipi=0.0
3167        endif
3168
3169 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3170         num_conti=num_cont_hb(i)
3171         do j=ielstart(i),ielend(i)
3172 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3173           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3174           call eelecij(i,j,ees,evdw1,eel_loc)
3175         enddo ! j
3176         num_cont_hb(i)=num_conti
3177       enddo   ! i
3178 !      write (iout,*) "Number of loop steps in EELEC:",ind
3179 !d      do i=1,nres
3180 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3181 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3182 !d      enddo
3183 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3184 !cc      eel_loc=eel_loc+eello_turn3
3185 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3186       return
3187       end subroutine eelec
3188 !-----------------------------------------------------------------------------
3189       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3190
3191       use comm_locel
3192 !      implicit real*8 (a-h,o-z)
3193 !      include 'DIMENSIONS'
3194 #ifdef MPI
3195       include "mpif.h"
3196 #endif
3197 !      include 'COMMON.CONTROL'
3198 !      include 'COMMON.IOUNITS'
3199 !      include 'COMMON.GEO'
3200 !      include 'COMMON.VAR'
3201 !      include 'COMMON.LOCAL'
3202 !      include 'COMMON.CHAIN'
3203 !      include 'COMMON.DERIV'
3204 !      include 'COMMON.INTERACT'
3205 !      include 'COMMON.CONTACTS'
3206 !      include 'COMMON.TORSION'
3207 !      include 'COMMON.VECTORS'
3208 !      include 'COMMON.FFIELD'
3209 !      include 'COMMON.TIME1'
3210       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3211       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3212       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3213 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3214       real(kind=8),dimension(4) :: muij
3215       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3216                     dist_temp, dist_init,rlocshield,fracinbuf
3217       integer xshift,yshift,zshift,ilist,iresshield
3218 !el      integer :: num_conti,j1,j2
3219 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3220 !el        dz_normi,xmedi,ymedi,zmedi
3221
3222 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3223 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3224 !el          num_conti,j1,j2
3225
3226 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3227 #ifdef MOMENT
3228       real(kind=8) :: scal_el=1.0d0
3229 #else
3230       real(kind=8) :: scal_el=0.5d0
3231 #endif
3232 ! 12/13/98
3233 ! 13-go grudnia roku pamietnego...
3234       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3235                                              0.0d0,1.0d0,0.0d0,&
3236                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3237 !      integer :: maxconts=nres/4
3238 !el local variables
3239       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3240       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3241       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3242       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3243                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3244                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3245                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3246                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3247                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3248                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3249                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3250 !      maxconts=nres/4
3251 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3252 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3253
3254 !          time00=MPI_Wtime()
3255 !d      write (iout,*) "eelecij",i,j
3256 !          ind=ind+1
3257           iteli=itel(i)
3258           itelj=itel(j)
3259           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3260           aaa=app(iteli,itelj)
3261           bbb=bpp(iteli,itelj)
3262           ael6i=ael6(iteli,itelj)
3263           ael3i=ael3(iteli,itelj)
3264           dxj=dc(1,j)
3265           dyj=dc(2,j)
3266           dzj=dc(3,j)
3267           dx_normj=dc_norm(1,j)
3268           dy_normj=dc_norm(2,j)
3269           dz_normj=dc_norm(3,j)
3270 !          xj=c(1,j)+0.5D0*dxj-xmedi
3271 !          yj=c(2,j)+0.5D0*dyj-ymedi
3272 !          zj=c(3,j)+0.5D0*dzj-zmedi
3273           xj=c(1,j)+0.5D0*dxj
3274           yj=c(2,j)+0.5D0*dyj
3275           zj=c(3,j)+0.5D0*dzj
3276           xj=mod(xj,boxxsize)
3277           if (xj.lt.0) xj=xj+boxxsize
3278           yj=mod(yj,boxysize)
3279           if (yj.lt.0) yj=yj+boxysize
3280           zj=mod(zj,boxzsize)
3281           if (zj.lt.0) zj=zj+boxzsize
3282        if ((zj.gt.bordlipbot)  &
3283        .and.(zj.lt.bordliptop)) then
3284 !C the energy transfer exist
3285         if (zj.lt.buflipbot) then
3286 !C what fraction I am in
3287          fracinbuf=1.0d0-     &
3288              ((zj-bordlipbot)/lipbufthick)
3289 !C lipbufthick is thickenes of lipid buffore
3290          sslipj=sscalelip(fracinbuf)
3291          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3292         elseif (zj.gt.bufliptop) then
3293          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3294          sslipj=sscalelip(fracinbuf)
3295          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3296         else
3297          sslipj=1.0d0
3298          ssgradlipj=0.0
3299         endif
3300        else
3301          sslipj=0.0d0
3302          ssgradlipj=0.0
3303        endif
3304
3305       isubchap=0
3306       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3307       xj_safe=xj
3308       yj_safe=yj
3309       zj_safe=zj
3310       do xshift=-1,1
3311       do yshift=-1,1
3312       do zshift=-1,1
3313           xj=xj_safe+xshift*boxxsize
3314           yj=yj_safe+yshift*boxysize
3315           zj=zj_safe+zshift*boxzsize
3316           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3317           if(dist_temp.lt.dist_init) then
3318             dist_init=dist_temp
3319             xj_temp=xj
3320             yj_temp=yj
3321             zj_temp=zj
3322             isubchap=1
3323           endif
3324        enddo
3325        enddo
3326        enddo
3327        if (isubchap.eq.1) then
3328 !C          print *,i,j
3329           xj=xj_temp-xmedi
3330           yj=yj_temp-ymedi
3331           zj=zj_temp-zmedi
3332        else
3333           xj=xj_safe-xmedi
3334           yj=yj_safe-ymedi
3335           zj=zj_safe-zmedi
3336        endif
3337
3338           rij=xj*xj+yj*yj+zj*zj
3339           rrmij=1.0D0/rij
3340           rij=dsqrt(rij)
3341 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3342             sss_ele_cut=sscale_ele(rij)
3343             sss_ele_grad=sscagrad_ele(rij)
3344 !             sss_ele_cut=1.0d0
3345 !             sss_ele_grad=0.0d0
3346 !            print *,sss_ele_cut,sss_ele_grad,&
3347 !            (rij),r_cut_ele,rlamb_ele
3348 !            if (sss_ele_cut.le.0.0) go to 128
3349
3350           rmij=1.0D0/rij
3351           r3ij=rrmij*rmij
3352           r6ij=r3ij*r3ij
3353           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3354           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3355           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3356           fac=cosa-3.0D0*cosb*cosg
3357           ev1=aaa*r6ij*r6ij
3358 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3359           if (j.eq.i+2) ev1=scal_el*ev1
3360           ev2=bbb*r6ij
3361           fac3=ael6i*r6ij
3362           fac4=ael3i*r3ij
3363           evdwij=ev1+ev2
3364           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3365           el2=fac4*fac
3366 !          eesij=el1+el2
3367           if (shield_mode.gt.0) then
3368 !C          fac_shield(i)=0.4
3369 !C          fac_shield(j)=0.6
3370           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3371           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3372           eesij=(el1+el2)
3373           ees=ees+eesij*sss_ele_cut
3374 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3375 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3376           else
3377           fac_shield(i)=1.0
3378           fac_shield(j)=1.0
3379           eesij=(el1+el2)
3380           ees=ees+eesij   &
3381             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3382 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3383           endif
3384
3385 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3386           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3387 !          ees=ees+eesij*sss_ele_cut
3388           evdw1=evdw1+evdwij*sss_ele_cut  &
3389            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3390 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3391 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3392 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3393 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3394
3395           if (energy_dec) then
3396 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3397 !                  'evdw1',i,j,evdwij,&
3398 !                  iteli,itelj,aaa,evdw1
3399               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3400               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3401           endif
3402 !
3403 ! Calculate contributions to the Cartesian gradient.
3404 !
3405 #ifdef SPLITELE
3406           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3407               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3408           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3409              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3410           fac1=fac
3411           erij(1)=xj*rmij
3412           erij(2)=yj*rmij
3413           erij(3)=zj*rmij
3414 !
3415 ! Radial derivatives. First process both termini of the fragment (i,j)
3416 !
3417           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3418           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3419           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3420            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3421           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3422             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3423
3424           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3425           (shield_mode.gt.0)) then
3426 !C          print *,i,j
3427           do ilist=1,ishield_list(i)
3428            iresshield=shield_list(ilist,i)
3429            do k=1,3
3430            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3431            *2.0*sss_ele_cut
3432            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3433                    rlocshield &
3434             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3435             *sss_ele_cut
3436             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3437            enddo
3438           enddo
3439           do ilist=1,ishield_list(j)
3440            iresshield=shield_list(ilist,j)
3441            do k=1,3
3442            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3443           *2.0*sss_ele_cut
3444            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3445                    rlocshield &
3446            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3447            *sss_ele_cut
3448            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3449            enddo
3450           enddo
3451           do k=1,3
3452             gshieldc(k,i)=gshieldc(k,i)+ &
3453                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3454            *sss_ele_cut
3455
3456             gshieldc(k,j)=gshieldc(k,j)+ &
3457                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3458            *sss_ele_cut
3459
3460             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3461                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3462            *sss_ele_cut
3463
3464             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3465                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3466            *sss_ele_cut
3467
3468            enddo
3469            endif
3470
3471
3472 !          do k=1,3
3473 !            ghalf=0.5D0*ggg(k)
3474 !            gelc(k,i)=gelc(k,i)+ghalf
3475 !            gelc(k,j)=gelc(k,j)+ghalf
3476 !          enddo
3477 ! 9/28/08 AL Gradient compotents will be summed only at the end
3478           do k=1,3
3479             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3480             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3481           enddo
3482             gelc_long(3,j)=gelc_long(3,j)+  &
3483           ssgradlipj*eesij/2.0d0*lipscale**2&
3484            *sss_ele_cut
3485
3486             gelc_long(3,i)=gelc_long(3,i)+  &
3487           ssgradlipi*eesij/2.0d0*lipscale**2&
3488            *sss_ele_cut
3489
3490
3491 !
3492 ! Loop over residues i+1 thru j-1.
3493 !
3494 !grad          do k=i+1,j-1
3495 !grad            do l=1,3
3496 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3497 !grad            enddo
3498 !grad          enddo
3499           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3500            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3501           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3502            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3503           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3504            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3505
3506 !          do k=1,3
3507 !            ghalf=0.5D0*ggg(k)
3508 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3509 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3510 !          enddo
3511 ! 9/28/08 AL Gradient compotents will be summed only at the end
3512           do k=1,3
3513             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3514             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3515           enddo
3516
3517 !C Lipidic part for scaling weight
3518            gvdwpp(3,j)=gvdwpp(3,j)+ &
3519           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3520            gvdwpp(3,i)=gvdwpp(3,i)+ &
3521           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3522 !! Loop over residues i+1 thru j-1.
3523 !
3524 !grad          do k=i+1,j-1
3525 !grad            do l=1,3
3526 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3527 !grad            enddo
3528 !grad          enddo
3529 #else
3530           facvdw=(ev1+evdwij)*sss_ele_cut &
3531            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3532
3533           facel=(el1+eesij)*sss_ele_cut
3534           fac1=fac
3535           fac=-3*rrmij*(facvdw+facvdw+facel)
3536           erij(1)=xj*rmij
3537           erij(2)=yj*rmij
3538           erij(3)=zj*rmij
3539 !
3540 ! Radial derivatives. First process both termini of the fragment (i,j)
3541 !
3542           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3543           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3544           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3545 !          do k=1,3
3546 !            ghalf=0.5D0*ggg(k)
3547 !            gelc(k,i)=gelc(k,i)+ghalf
3548 !            gelc(k,j)=gelc(k,j)+ghalf
3549 !          enddo
3550 ! 9/28/08 AL Gradient compotents will be summed only at the end
3551           do k=1,3
3552             gelc_long(k,j)=gelc(k,j)+ggg(k)
3553             gelc_long(k,i)=gelc(k,i)-ggg(k)
3554           enddo
3555 !
3556 ! Loop over residues i+1 thru j-1.
3557 !
3558 !grad          do k=i+1,j-1
3559 !grad            do l=1,3
3560 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3561 !grad            enddo
3562 !grad          enddo
3563 ! 9/28/08 AL Gradient compotents will be summed only at the end
3564           ggg(1)=facvdw*xj &
3565            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3566           ggg(2)=facvdw*yj &
3567            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3568           ggg(3)=facvdw*zj &
3569            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3570
3571           do k=1,3
3572             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3573             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3574           enddo
3575            gvdwpp(3,j)=gvdwpp(3,j)+ &
3576           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3577            gvdwpp(3,i)=gvdwpp(3,i)+ &
3578           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3579
3580 #endif
3581 !
3582 ! Angular part
3583 !
3584           ecosa=2.0D0*fac3*fac1+fac4
3585           fac4=-3.0D0*fac4
3586           fac3=-6.0D0*fac3
3587           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3588           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3589           do k=1,3
3590             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3591             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3592           enddo
3593 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3594 !d   &          (dcosg(k),k=1,3)
3595           do k=1,3
3596             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3597              *fac_shield(i)**2*fac_shield(j)**2 &
3598              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3599
3600           enddo
3601 !          do k=1,3
3602 !            ghalf=0.5D0*ggg(k)
3603 !            gelc(k,i)=gelc(k,i)+ghalf
3604 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3605 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3606 !            gelc(k,j)=gelc(k,j)+ghalf
3607 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3608 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3609 !          enddo
3610 !grad          do k=i+1,j-1
3611 !grad            do l=1,3
3612 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3613 !grad            enddo
3614 !grad          enddo
3615           do k=1,3
3616             gelc(k,i)=gelc(k,i) &
3617                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3618                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3619                      *sss_ele_cut &
3620                      *fac_shield(i)**2*fac_shield(j)**2 &
3621                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3622
3623             gelc(k,j)=gelc(k,j) &
3624                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3625                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3626                      *sss_ele_cut  &
3627                      *fac_shield(i)**2*fac_shield(j)**2  &
3628                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3629
3630             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3631             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3632           enddo
3633
3634           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3635               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3636               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3637 !
3638 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3639 !   energy of a peptide unit is assumed in the form of a second-order
3640 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3641 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3642 !   are computed for EVERY pair of non-contiguous peptide groups.
3643 !
3644           if (j.lt.nres-1) then
3645             j1=j+1
3646             j2=j-1
3647           else
3648             j1=j-1
3649             j2=j-2
3650           endif
3651           kkk=0
3652           do k=1,2
3653             do l=1,2
3654               kkk=kkk+1
3655               muij(kkk)=mu(k,i)*mu(l,j)
3656             enddo
3657           enddo
3658 !d         write (iout,*) 'EELEC: i',i,' j',j
3659 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3660 !d          write(iout,*) 'muij',muij
3661           ury=scalar(uy(1,i),erij)
3662           urz=scalar(uz(1,i),erij)
3663           vry=scalar(uy(1,j),erij)
3664           vrz=scalar(uz(1,j),erij)
3665           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3666           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3667           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3668           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3669           fac=dsqrt(-ael6i)*r3ij
3670           a22=a22*fac
3671           a23=a23*fac
3672           a32=a32*fac
3673           a33=a33*fac
3674 !d          write (iout,'(4i5,4f10.5)')
3675 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3676 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3677 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3678 !d     &      uy(:,j),uz(:,j)
3679 !d          write (iout,'(4f10.5)')
3680 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3681 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3682 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3683 !d           write (iout,'(9f10.5/)')
3684 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3685 ! Derivatives of the elements of A in virtual-bond vectors
3686           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3687           do k=1,3
3688             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3689             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3690             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3691             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3692             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3693             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3694             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3695             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3696             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3697             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3698             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3699             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3700           enddo
3701 ! Compute radial contributions to the gradient
3702           facr=-3.0d0*rrmij
3703           a22der=a22*facr
3704           a23der=a23*facr
3705           a32der=a32*facr
3706           a33der=a33*facr
3707           agg(1,1)=a22der*xj
3708           agg(2,1)=a22der*yj
3709           agg(3,1)=a22der*zj
3710           agg(1,2)=a23der*xj
3711           agg(2,2)=a23der*yj
3712           agg(3,2)=a23der*zj
3713           agg(1,3)=a32der*xj
3714           agg(2,3)=a32der*yj
3715           agg(3,3)=a32der*zj
3716           agg(1,4)=a33der*xj
3717           agg(2,4)=a33der*yj
3718           agg(3,4)=a33der*zj
3719 ! Add the contributions coming from er
3720           fac3=-3.0d0*fac
3721           do k=1,3
3722             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3723             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3724             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3725             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3726           enddo
3727           do k=1,3
3728 ! Derivatives in DC(i)
3729 !grad            ghalf1=0.5d0*agg(k,1)
3730 !grad            ghalf2=0.5d0*agg(k,2)
3731 !grad            ghalf3=0.5d0*agg(k,3)
3732 !grad            ghalf4=0.5d0*agg(k,4)
3733             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3734             -3.0d0*uryg(k,2)*vry)!+ghalf1
3735             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3736             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3737             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3738             -3.0d0*urzg(k,2)*vry)!+ghalf3
3739             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3740             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3741 ! Derivatives in DC(i+1)
3742             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3743             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3744             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3745             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3746             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3747             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3748             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3749             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3750 ! Derivatives in DC(j)
3751             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3752             -3.0d0*vryg(k,2)*ury)!+ghalf1
3753             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3754             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3755             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3756             -3.0d0*vryg(k,2)*urz)!+ghalf3
3757             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3758             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3759 ! Derivatives in DC(j+1) or DC(nres-1)
3760             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3761             -3.0d0*vryg(k,3)*ury)
3762             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3763             -3.0d0*vrzg(k,3)*ury)
3764             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3765             -3.0d0*vryg(k,3)*urz)
3766             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3767             -3.0d0*vrzg(k,3)*urz)
3768 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3769 !grad              do l=1,4
3770 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3771 !grad              enddo
3772 !grad            endif
3773           enddo
3774           acipa(1,1)=a22
3775           acipa(1,2)=a23
3776           acipa(2,1)=a32
3777           acipa(2,2)=a33
3778           a22=-a22
3779           a23=-a23
3780           do l=1,2
3781             do k=1,3
3782               agg(k,l)=-agg(k,l)
3783               aggi(k,l)=-aggi(k,l)
3784               aggi1(k,l)=-aggi1(k,l)
3785               aggj(k,l)=-aggj(k,l)
3786               aggj1(k,l)=-aggj1(k,l)
3787             enddo
3788           enddo
3789           if (j.lt.nres-1) then
3790             a22=-a22
3791             a32=-a32
3792             do l=1,3,2
3793               do k=1,3
3794                 agg(k,l)=-agg(k,l)
3795                 aggi(k,l)=-aggi(k,l)
3796                 aggi1(k,l)=-aggi1(k,l)
3797                 aggj(k,l)=-aggj(k,l)
3798                 aggj1(k,l)=-aggj1(k,l)
3799               enddo
3800             enddo
3801           else
3802             a22=-a22
3803             a23=-a23
3804             a32=-a32
3805             a33=-a33
3806             do l=1,4
3807               do k=1,3
3808                 agg(k,l)=-agg(k,l)
3809                 aggi(k,l)=-aggi(k,l)
3810                 aggi1(k,l)=-aggi1(k,l)
3811                 aggj(k,l)=-aggj(k,l)
3812                 aggj1(k,l)=-aggj1(k,l)
3813               enddo
3814             enddo
3815           endif
3816           ENDIF ! WCORR
3817           IF (wel_loc.gt.0.0d0) THEN
3818 ! Contribution to the local-electrostatic energy coming from the i-j pair
3819           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3820            +a33*muij(4)
3821           if (shield_mode.eq.0) then
3822            fac_shield(i)=1.0
3823            fac_shield(j)=1.0
3824           endif
3825           eel_loc_ij=eel_loc_ij &
3826          *fac_shield(i)*fac_shield(j) &
3827          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3828 !C Now derivative over eel_loc
3829           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3830          (shield_mode.gt.0)) then
3831 !C          print *,i,j
3832
3833           do ilist=1,ishield_list(i)
3834            iresshield=shield_list(ilist,i)
3835            do k=1,3
3836            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3837                                                 /fac_shield(i)&
3838            *sss_ele_cut
3839            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3840                    rlocshield  &
3841           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3842           *sss_ele_cut
3843
3844             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3845            +rlocshield
3846            enddo
3847           enddo
3848           do ilist=1,ishield_list(j)
3849            iresshield=shield_list(ilist,j)
3850            do k=1,3
3851            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3852                                             /fac_shield(j)   &
3853             *sss_ele_cut
3854            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3855                    rlocshield  &
3856       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3857        *sss_ele_cut
3858
3859            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3860                   +rlocshield
3861
3862            enddo
3863           enddo
3864
3865           do k=1,3
3866             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3867                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3868                     *sss_ele_cut
3869             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3870                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3871                     *sss_ele_cut
3872             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3873                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3874                     *sss_ele_cut
3875             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3876                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3877                     *sss_ele_cut
3878
3879            enddo
3880            endif
3881
3882
3883 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3884 !           eel_loc_ij=0.0
3885           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3886                   'eelloc',i,j,eel_loc_ij
3887 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3888 !          if (energy_dec) write (iout,*) "muij",muij
3889 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3890
3891           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3892 ! Partial derivatives in virtual-bond dihedral angles gamma
3893           if (i.gt.1) &
3894           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3895                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3896                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3897                  *sss_ele_cut  &
3898           *fac_shield(i)*fac_shield(j) &
3899           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3900
3901           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3902                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3903                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3904                  *sss_ele_cut &
3905           *fac_shield(i)*fac_shield(j) &
3906           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3907 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3908 !          do l=1,3
3909 !            ggg(1)=(agg(1,1)*muij(1)+ &
3910 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3911 !            *sss_ele_cut &
3912 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3913 !            ggg(2)=(agg(2,1)*muij(1)+ &
3914 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3915 !            *sss_ele_cut &
3916 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3917 !            ggg(3)=(agg(3,1)*muij(1)+ &
3918 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3919 !            *sss_ele_cut &
3920 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3921            xtemp(1)=xj
3922            xtemp(2)=yj
3923            xtemp(3)=zj
3924
3925            do l=1,3
3926             ggg(l)=(agg(l,1)*muij(1)+ &
3927                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3928             *sss_ele_cut &
3929           *fac_shield(i)*fac_shield(j) &
3930           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
3931              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3932
3933
3934             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3935             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3936 !grad            ghalf=0.5d0*ggg(l)
3937 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3938 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3939           enddo
3940             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
3941           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
3942           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3943
3944             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
3945           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
3946           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3947
3948 !grad          do k=i+1,j2
3949 !grad            do l=1,3
3950 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3951 !grad            enddo
3952 !grad          enddo
3953 ! Remaining derivatives of eello
3954           do l=1,3
3955             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
3956                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
3957             *sss_ele_cut &
3958           *fac_shield(i)*fac_shield(j) &
3959           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3960
3961 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3962             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
3963                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
3964             +aggi1(l,4)*muij(4))&
3965             *sss_ele_cut &
3966           *fac_shield(i)*fac_shield(j) &
3967           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3968
3969 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3970             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
3971                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
3972             *sss_ele_cut &
3973           *fac_shield(i)*fac_shield(j) &
3974           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3975
3976 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3977             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
3978                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
3979             +aggj1(l,4)*muij(4))&
3980             *sss_ele_cut &
3981           *fac_shield(i)*fac_shield(j) &
3982           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3983
3984 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3985           enddo
3986           ENDIF
3987 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3988 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3989           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3990              .and. num_conti.le.maxconts) then
3991 !            write (iout,*) i,j," entered corr"
3992 !
3993 ! Calculate the contact function. The ith column of the array JCONT will
3994 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3995 ! greater than I). The arrays FACONT and GACONT will contain the values of
3996 ! the contact function and its derivative.
3997 !           r0ij=1.02D0*rpp(iteli,itelj)
3998 !           r0ij=1.11D0*rpp(iteli,itelj)
3999             r0ij=2.20D0*rpp(iteli,itelj)
4000 !           r0ij=1.55D0*rpp(iteli,itelj)
4001             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4002 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4003             if (fcont.gt.0.0D0) then
4004               num_conti=num_conti+1
4005               if (num_conti.gt.maxconts) then
4006 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4007 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4008                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4009                                ' will skip next contacts for this conf.', num_conti
4010               else
4011                 jcont_hb(num_conti,i)=j
4012 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4013 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4014                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4015                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4016 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4017 !  terms.
4018                 d_cont(num_conti,i)=rij
4019 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4020 !     --- Electrostatic-interaction matrix ---
4021                 a_chuj(1,1,num_conti,i)=a22
4022                 a_chuj(1,2,num_conti,i)=a23
4023                 a_chuj(2,1,num_conti,i)=a32
4024                 a_chuj(2,2,num_conti,i)=a33
4025 !     --- Gradient of rij
4026                 do kkk=1,3
4027                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4028                 enddo
4029                 kkll=0
4030                 do k=1,2
4031                   do l=1,2
4032                     kkll=kkll+1
4033                     do m=1,3
4034                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4035                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4036                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4037                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4038                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4039                     enddo
4040                   enddo
4041                 enddo
4042                 ENDIF
4043                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4044 ! Calculate contact energies
4045                 cosa4=4.0D0*cosa
4046                 wij=cosa-3.0D0*cosb*cosg
4047                 cosbg1=cosb+cosg
4048                 cosbg2=cosb-cosg
4049 !               fac3=dsqrt(-ael6i)/r0ij**3
4050                 fac3=dsqrt(-ael6i)*r3ij
4051 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4052                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4053                 if (ees0tmp.gt.0) then
4054                   ees0pij=dsqrt(ees0tmp)
4055                 else
4056                   ees0pij=0
4057                 endif
4058                 if (shield_mode.eq.0) then
4059                 fac_shield(i)=1.0d0
4060                 fac_shield(j)=1.0d0
4061                 else
4062                 ees0plist(num_conti,i)=j
4063                 endif
4064 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4065                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4066                 if (ees0tmp.gt.0) then
4067                   ees0mij=dsqrt(ees0tmp)
4068                 else
4069                   ees0mij=0
4070                 endif
4071 !               ees0mij=0.0D0
4072                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4073                      *sss_ele_cut &
4074                      *fac_shield(i)*fac_shield(j)
4075
4076                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4077                      *sss_ele_cut &
4078                      *fac_shield(i)*fac_shield(j)
4079
4080 ! Diagnostics. Comment out or remove after debugging!
4081 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4082 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4083 !               ees0m(num_conti,i)=0.0D0
4084 ! End diagnostics.
4085 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4086 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4087 ! Angular derivatives of the contact function
4088                 ees0pij1=fac3/ees0pij
4089                 ees0mij1=fac3/ees0mij
4090                 fac3p=-3.0D0*fac3*rrmij
4091                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4092                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4093 !               ees0mij1=0.0D0
4094                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4095                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4096                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4097                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4098                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4099                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4100                 ecosap=ecosa1+ecosa2
4101                 ecosbp=ecosb1+ecosb2
4102                 ecosgp=ecosg1+ecosg2
4103                 ecosam=ecosa1-ecosa2
4104                 ecosbm=ecosb1-ecosb2
4105                 ecosgm=ecosg1-ecosg2
4106 ! Diagnostics
4107 !               ecosap=ecosa1
4108 !               ecosbp=ecosb1
4109 !               ecosgp=ecosg1
4110 !               ecosam=0.0D0
4111 !               ecosbm=0.0D0
4112 !               ecosgm=0.0D0
4113 ! End diagnostics
4114                 facont_hb(num_conti,i)=fcont
4115                 fprimcont=fprimcont/rij
4116 !d              facont_hb(num_conti,i)=1.0D0
4117 ! Following line is for diagnostics.
4118 !d              fprimcont=0.0D0
4119                 do k=1,3
4120                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4121                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4122                 enddo
4123                 do k=1,3
4124                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4125                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4126                 enddo
4127                 gggp(1)=gggp(1)+ees0pijp*xj &
4128                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4129                 gggp(2)=gggp(2)+ees0pijp*yj &
4130                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4131                 gggp(3)=gggp(3)+ees0pijp*zj &
4132                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4133
4134                 gggm(1)=gggm(1)+ees0mijp*xj &
4135                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4136
4137                 gggm(2)=gggm(2)+ees0mijp*yj &
4138                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4139
4140                 gggm(3)=gggm(3)+ees0mijp*zj &
4141                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4142
4143 ! Derivatives due to the contact function
4144                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4145                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4146                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4147                 do k=1,3
4148 !
4149 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4150 !          following the change of gradient-summation algorithm.
4151 !
4152 !grad                  ghalfp=0.5D0*gggp(k)
4153 !grad                  ghalfm=0.5D0*gggm(k)
4154                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4155                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4156                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4157                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4158
4159                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4160                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4161                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4162                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4163
4164                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4165                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4166
4167                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4168                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4169                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4170                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4171
4172                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4173                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4174                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4175                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4176
4177                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4178                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4179
4180                 enddo
4181 ! Diagnostics. Comment out or remove after debugging!
4182 !diag           do k=1,3
4183 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4184 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4185 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4186 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4187 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4188 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4189 !diag           enddo
4190               ENDIF ! wcorr
4191               endif  ! num_conti.le.maxconts
4192             endif  ! fcont.gt.0
4193           endif    ! j.gt.i+1
4194           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4195             do k=1,4
4196               do l=1,3
4197                 ghalf=0.5d0*agg(l,k)
4198                 aggi(l,k)=aggi(l,k)+ghalf
4199                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4200                 aggj(l,k)=aggj(l,k)+ghalf
4201               enddo
4202             enddo
4203             if (j.eq.nres-1 .and. i.lt.j-2) then
4204               do k=1,4
4205                 do l=1,3
4206                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4207                 enddo
4208               enddo
4209             endif
4210           endif
4211  128  continue
4212 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4213       return
4214       end subroutine eelecij
4215 !-----------------------------------------------------------------------------
4216       subroutine eturn3(i,eello_turn3)
4217 ! Third- and fourth-order contributions from turns
4218
4219       use comm_locel
4220 !      implicit real*8 (a-h,o-z)
4221 !      include 'DIMENSIONS'
4222 !      include 'COMMON.IOUNITS'
4223 !      include 'COMMON.GEO'
4224 !      include 'COMMON.VAR'
4225 !      include 'COMMON.LOCAL'
4226 !      include 'COMMON.CHAIN'
4227 !      include 'COMMON.DERIV'
4228 !      include 'COMMON.INTERACT'
4229 !      include 'COMMON.CONTACTS'
4230 !      include 'COMMON.TORSION'
4231 !      include 'COMMON.VECTORS'
4232 !      include 'COMMON.FFIELD'
4233 !      include 'COMMON.CONTROL'
4234       real(kind=8),dimension(3) :: ggg
4235       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4236         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4237       real(kind=8),dimension(2) :: auxvec,auxvec1
4238 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4239       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4240 !el      integer :: num_conti,j1,j2
4241 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4242 !el        dz_normi,xmedi,ymedi,zmedi
4243
4244 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4245 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4246 !el         num_conti,j1,j2
4247 !el local variables
4248       integer :: i,j,l,k,ilist,iresshield
4249       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4250
4251       j=i+2
4252 !      write (iout,*) "eturn3",i,j,j1,j2
4253           zj=(c(3,j)+c(3,j+1))/2.0d0
4254           zj=mod(zj,boxzsize)
4255           if (zj.lt.0) zj=zj+boxzsize
4256           if ((zj.lt.0)) write (*,*) "CHUJ"
4257        if ((zj.gt.bordlipbot)  &
4258         .and.(zj.lt.bordliptop)) then
4259 !C the energy transfer exist
4260         if (zj.lt.buflipbot) then
4261 !C what fraction I am in
4262          fracinbuf=1.0d0-     &
4263              ((zj-bordlipbot)/lipbufthick)
4264 !C lipbufthick is thickenes of lipid buffore
4265          sslipj=sscalelip(fracinbuf)
4266          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4267         elseif (zj.gt.bufliptop) then
4268          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4269          sslipj=sscalelip(fracinbuf)
4270          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4271         else
4272          sslipj=1.0d0
4273          ssgradlipj=0.0
4274         endif
4275        else
4276          sslipj=0.0d0
4277          ssgradlipj=0.0
4278        endif
4279
4280       a_temp(1,1)=a22
4281       a_temp(1,2)=a23
4282       a_temp(2,1)=a32
4283       a_temp(2,2)=a33
4284 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4285 !
4286 !               Third-order contributions
4287 !
4288 !                 (i+2)o----(i+3)
4289 !                      | |
4290 !                      | |
4291 !                 (i+1)o----i
4292 !
4293 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4294 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4295         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4296         call transpose2(auxmat(1,1),auxmat1(1,1))
4297         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4298         if (shield_mode.eq.0) then
4299         fac_shield(i)=1.0d0
4300         fac_shield(j)=1.0d0
4301         endif
4302
4303         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4304          *fac_shield(i)*fac_shield(j)  &
4305          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4306         eello_t3= &
4307         0.5d0*(pizda(1,1)+pizda(2,2)) &
4308         *fac_shield(i)*fac_shield(j)
4309
4310         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4311                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4312           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4313        (shield_mode.gt.0)) then
4314 !C          print *,i,j
4315
4316           do ilist=1,ishield_list(i)
4317            iresshield=shield_list(ilist,i)
4318            do k=1,3
4319            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4320            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4321                    rlocshield &
4322            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4323             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4324              +rlocshield
4325            enddo
4326           enddo
4327           do ilist=1,ishield_list(j)
4328            iresshield=shield_list(ilist,j)
4329            do k=1,3
4330            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4331            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4332                    rlocshield &
4333            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4334            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4335                   +rlocshield
4336
4337            enddo
4338           enddo
4339
4340           do k=1,3
4341             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4342                    grad_shield(k,i)*eello_t3/fac_shield(i)
4343             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4344                    grad_shield(k,j)*eello_t3/fac_shield(j)
4345             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4346                    grad_shield(k,i)*eello_t3/fac_shield(i)
4347             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4348                    grad_shield(k,j)*eello_t3/fac_shield(j)
4349            enddo
4350            endif
4351
4352 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4353 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4354 !d     &    ' eello_turn3_num',4*eello_turn3_num
4355 ! Derivatives in gamma(i)
4356         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4357         call transpose2(auxmat2(1,1),auxmat3(1,1))
4358         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4359         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4360           *fac_shield(i)*fac_shield(j)        &
4361           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4362 ! Derivatives in gamma(i+1)
4363         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4364         call transpose2(auxmat2(1,1),auxmat3(1,1))
4365         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4366         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4367           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4368           *fac_shield(i)*fac_shield(j)        &
4369           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4370
4371 ! Cartesian derivatives
4372         do l=1,3
4373 !            ghalf1=0.5d0*agg(l,1)
4374 !            ghalf2=0.5d0*agg(l,2)
4375 !            ghalf3=0.5d0*agg(l,3)
4376 !            ghalf4=0.5d0*agg(l,4)
4377           a_temp(1,1)=aggi(l,1)!+ghalf1
4378           a_temp(1,2)=aggi(l,2)!+ghalf2
4379           a_temp(2,1)=aggi(l,3)!+ghalf3
4380           a_temp(2,2)=aggi(l,4)!+ghalf4
4381           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4382           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4383             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4384           *fac_shield(i)*fac_shield(j)      &
4385           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4386
4387           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4388           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4389           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4390           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4391           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4392           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4393             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4394           *fac_shield(i)*fac_shield(j)        &
4395           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4396
4397           a_temp(1,1)=aggj(l,1)!+ghalf1
4398           a_temp(1,2)=aggj(l,2)!+ghalf2
4399           a_temp(2,1)=aggj(l,3)!+ghalf3
4400           a_temp(2,2)=aggj(l,4)!+ghalf4
4401           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4402           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4403             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4404           *fac_shield(i)*fac_shield(j)      &
4405           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4406
4407           a_temp(1,1)=aggj1(l,1)
4408           a_temp(1,2)=aggj1(l,2)
4409           a_temp(2,1)=aggj1(l,3)
4410           a_temp(2,2)=aggj1(l,4)
4411           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4412           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4413             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4414           *fac_shield(i)*fac_shield(j)        &
4415           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4416         enddo
4417          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4418           ssgradlipi*eello_t3/4.0d0*lipscale
4419          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4420           ssgradlipj*eello_t3/4.0d0*lipscale
4421          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4422           ssgradlipi*eello_t3/4.0d0*lipscale
4423          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4424           ssgradlipj*eello_t3/4.0d0*lipscale
4425
4426       return
4427       end subroutine eturn3
4428 !-----------------------------------------------------------------------------
4429       subroutine eturn4(i,eello_turn4)
4430 ! Third- and fourth-order contributions from turns
4431
4432       use comm_locel
4433 !      implicit real*8 (a-h,o-z)
4434 !      include 'DIMENSIONS'
4435 !      include 'COMMON.IOUNITS'
4436 !      include 'COMMON.GEO'
4437 !      include 'COMMON.VAR'
4438 !      include 'COMMON.LOCAL'
4439 !      include 'COMMON.CHAIN'
4440 !      include 'COMMON.DERIV'
4441 !      include 'COMMON.INTERACT'
4442 !      include 'COMMON.CONTACTS'
4443 !      include 'COMMON.TORSION'
4444 !      include 'COMMON.VECTORS'
4445 !      include 'COMMON.FFIELD'
4446 !      include 'COMMON.CONTROL'
4447       real(kind=8),dimension(3) :: ggg
4448       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4449         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4450       real(kind=8),dimension(2) :: auxvec,auxvec1
4451 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4452       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4453 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4454 !el        dz_normi,xmedi,ymedi,zmedi
4455 !el      integer :: num_conti,j1,j2
4456 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4457 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4458 !el          num_conti,j1,j2
4459 !el local variables
4460       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4461       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4462          rlocshield
4463
4464       j=i+3
4465 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4466 !
4467 !               Fourth-order contributions
4468 !
4469 !                 (i+3)o----(i+4)
4470 !                     /  |
4471 !               (i+2)o   |
4472 !                     \  |
4473 !                 (i+1)o----i
4474 !
4475 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4476 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4477 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4478           zj=(c(3,j)+c(3,j+1))/2.0d0
4479           zj=mod(zj,boxzsize)
4480           if (zj.lt.0) zj=zj+boxzsize
4481        if ((zj.gt.bordlipbot)  &
4482         .and.(zj.lt.bordliptop)) then
4483 !C the energy transfer exist
4484         if (zj.lt.buflipbot) then
4485 !C what fraction I am in
4486          fracinbuf=1.0d0-     &
4487              ((zj-bordlipbot)/lipbufthick)
4488 !C lipbufthick is thickenes of lipid buffore
4489          sslipj=sscalelip(fracinbuf)
4490          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4491         elseif (zj.gt.bufliptop) then
4492          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4493          sslipj=sscalelip(fracinbuf)
4494          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4495         else
4496          sslipj=1.0d0
4497          ssgradlipj=0.0
4498         endif
4499        else
4500          sslipj=0.0d0
4501          ssgradlipj=0.0
4502        endif
4503
4504         a_temp(1,1)=a22
4505         a_temp(1,2)=a23
4506         a_temp(2,1)=a32
4507         a_temp(2,2)=a33
4508         iti1=itortyp(itype(i+1,1))
4509         iti2=itortyp(itype(i+2,1))
4510         iti3=itortyp(itype(i+3,1))
4511 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4512         call transpose2(EUg(1,1,i+1),e1t(1,1))
4513         call transpose2(Eug(1,1,i+2),e2t(1,1))
4514         call transpose2(Eug(1,1,i+3),e3t(1,1))
4515         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4516         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4517         s1=scalar2(b1(1,iti2),auxvec(1))
4518         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4519         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4520         s2=scalar2(b1(1,iti1),auxvec(1))
4521         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4522         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4523         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4524         if (shield_mode.eq.0) then
4525         fac_shield(i)=1.0
4526         fac_shield(j)=1.0
4527         endif
4528
4529         eello_turn4=eello_turn4-(s1+s2+s3) &
4530         *fac_shield(i)*fac_shield(j)       &
4531         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4532         eello_t4=-(s1+s2+s3)  &
4533           *fac_shield(i)*fac_shield(j)
4534 !C Now derivative over shield:
4535           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4536          (shield_mode.gt.0)) then
4537 !C          print *,i,j
4538
4539           do ilist=1,ishield_list(i)
4540            iresshield=shield_list(ilist,i)
4541            do k=1,3
4542            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4543            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4544                    rlocshield &
4545             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4546             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4547            +rlocshield
4548            enddo
4549           enddo
4550           do ilist=1,ishield_list(j)
4551            iresshield=shield_list(ilist,j)
4552            do k=1,3
4553            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4554            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4555                    rlocshield  &
4556            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4557            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4558                   +rlocshield
4559
4560            enddo
4561           enddo
4562
4563           do k=1,3
4564             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4565                    grad_shield(k,i)*eello_t4/fac_shield(i)
4566             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4567                    grad_shield(k,j)*eello_t4/fac_shield(j)
4568             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4569                    grad_shield(k,i)*eello_t4/fac_shield(i)
4570             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4571                    grad_shield(k,j)*eello_t4/fac_shield(j)
4572            enddo
4573            endif
4574
4575         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4576            'eturn4',i,j,-(s1+s2+s3)
4577 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4578 !d     &    ' eello_turn4_num',8*eello_turn4_num
4579 ! Derivatives in gamma(i)
4580         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4581         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4582         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4583         s1=scalar2(b1(1,iti2),auxvec(1))
4584         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4585         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4586         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4587        *fac_shield(i)*fac_shield(j)  &
4588        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4589
4590 ! Derivatives in gamma(i+1)
4591         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4592         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4593         s2=scalar2(b1(1,iti1),auxvec(1))
4594         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4595         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4596         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4597         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4598        *fac_shield(i)*fac_shield(j)  &
4599        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4600
4601 ! Derivatives in gamma(i+2)
4602         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4603         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4604         s1=scalar2(b1(1,iti2),auxvec(1))
4605         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4606         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4607         s2=scalar2(b1(1,iti1),auxvec(1))
4608         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4609         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4610         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4611         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4612        *fac_shield(i)*fac_shield(j)  &
4613        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4614
4615 ! Cartesian derivatives
4616 ! Derivatives of this turn contributions in DC(i+2)
4617         if (j.lt.nres-1) then
4618           do l=1,3
4619             a_temp(1,1)=agg(l,1)
4620             a_temp(1,2)=agg(l,2)
4621             a_temp(2,1)=agg(l,3)
4622             a_temp(2,2)=agg(l,4)
4623             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4624             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4625             s1=scalar2(b1(1,iti2),auxvec(1))
4626             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4627             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4628             s2=scalar2(b1(1,iti1),auxvec(1))
4629             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4630             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4631             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4632             ggg(l)=-(s1+s2+s3)
4633             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4634        *fac_shield(i)*fac_shield(j)  &
4635        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4636
4637           enddo
4638         endif
4639 ! Remaining derivatives of this turn contribution
4640         do l=1,3
4641           a_temp(1,1)=aggi(l,1)
4642           a_temp(1,2)=aggi(l,2)
4643           a_temp(2,1)=aggi(l,3)
4644           a_temp(2,2)=aggi(l,4)
4645           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4646           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4647           s1=scalar2(b1(1,iti2),auxvec(1))
4648           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4649           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4650           s2=scalar2(b1(1,iti1),auxvec(1))
4651           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4652           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4653           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4654           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4655          *fac_shield(i)*fac_shield(j)  &
4656          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4657
4658
4659           a_temp(1,1)=aggi1(l,1)
4660           a_temp(1,2)=aggi1(l,2)
4661           a_temp(2,1)=aggi1(l,3)
4662           a_temp(2,2)=aggi1(l,4)
4663           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4664           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4665           s1=scalar2(b1(1,iti2),auxvec(1))
4666           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4667           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4668           s2=scalar2(b1(1,iti1),auxvec(1))
4669           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4670           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4671           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4672           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4673          *fac_shield(i)*fac_shield(j)  &
4674          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4675
4676
4677           a_temp(1,1)=aggj(l,1)
4678           a_temp(1,2)=aggj(l,2)
4679           a_temp(2,1)=aggj(l,3)
4680           a_temp(2,2)=aggj(l,4)
4681           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4682           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4683           s1=scalar2(b1(1,iti2),auxvec(1))
4684           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4685           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4686           s2=scalar2(b1(1,iti1),auxvec(1))
4687           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4688           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4689           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4690           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4691          *fac_shield(i)*fac_shield(j)  &
4692          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4693
4694
4695           a_temp(1,1)=aggj1(l,1)
4696           a_temp(1,2)=aggj1(l,2)
4697           a_temp(2,1)=aggj1(l,3)
4698           a_temp(2,2)=aggj1(l,4)
4699           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4700           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4701           s1=scalar2(b1(1,iti2),auxvec(1))
4702           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4703           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4704           s2=scalar2(b1(1,iti1),auxvec(1))
4705           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4706           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4707           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4708 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4709           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4710          *fac_shield(i)*fac_shield(j)  &
4711          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4712
4713         enddo
4714          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4715           ssgradlipi*eello_t4/4.0d0*lipscale
4716          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4717           ssgradlipj*eello_t4/4.0d0*lipscale
4718          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4719           ssgradlipi*eello_t4/4.0d0*lipscale
4720          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4721           ssgradlipj*eello_t4/4.0d0*lipscale
4722
4723       return
4724       end subroutine eturn4
4725 !-----------------------------------------------------------------------------
4726       subroutine unormderiv(u,ugrad,unorm,ungrad)
4727 ! This subroutine computes the derivatives of a normalized vector u, given
4728 ! the derivatives computed without normalization conditions, ugrad. Returns
4729 ! ungrad.
4730 !      implicit none
4731       real(kind=8),dimension(3) :: u,vec
4732       real(kind=8),dimension(3,3) ::ugrad,ungrad
4733       real(kind=8) :: unorm      !,scalar
4734       integer :: i,j
4735 !      write (2,*) 'ugrad',ugrad
4736 !      write (2,*) 'u',u
4737       do i=1,3
4738         vec(i)=scalar(ugrad(1,i),u(1))
4739       enddo
4740 !      write (2,*) 'vec',vec
4741       do i=1,3
4742         do j=1,3
4743           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4744         enddo
4745       enddo
4746 !      write (2,*) 'ungrad',ungrad
4747       return
4748       end subroutine unormderiv
4749 !-----------------------------------------------------------------------------
4750       subroutine escp_soft_sphere(evdw2,evdw2_14)
4751 !
4752 ! This subroutine calculates the excluded-volume interaction energy between
4753 ! peptide-group centers and side chains and its gradient in virtual-bond and
4754 ! side-chain vectors.
4755 !
4756 !      implicit real*8 (a-h,o-z)
4757 !      include 'DIMENSIONS'
4758 !      include 'COMMON.GEO'
4759 !      include 'COMMON.VAR'
4760 !      include 'COMMON.LOCAL'
4761 !      include 'COMMON.CHAIN'
4762 !      include 'COMMON.DERIV'
4763 !      include 'COMMON.INTERACT'
4764 !      include 'COMMON.FFIELD'
4765 !      include 'COMMON.IOUNITS'
4766 !      include 'COMMON.CONTROL'
4767       real(kind=8),dimension(3) :: ggg
4768 !el local variables
4769       integer :: i,iint,j,k,iteli,itypj
4770       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4771                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4772
4773       evdw2=0.0D0
4774       evdw2_14=0.0d0
4775       r0_scp=4.5d0
4776 !d    print '(a)','Enter ESCP'
4777 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4778       do i=iatscp_s,iatscp_e
4779         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4780         iteli=itel(i)
4781         xi=0.5D0*(c(1,i)+c(1,i+1))
4782         yi=0.5D0*(c(2,i)+c(2,i+1))
4783         zi=0.5D0*(c(3,i)+c(3,i+1))
4784
4785         do iint=1,nscp_gr(i)
4786
4787         do j=iscpstart(i,iint),iscpend(i,iint)
4788           if (itype(j,1).eq.ntyp1) cycle
4789           itypj=iabs(itype(j,1))
4790 ! Uncomment following three lines for SC-p interactions
4791 !         xj=c(1,nres+j)-xi
4792 !         yj=c(2,nres+j)-yi
4793 !         zj=c(3,nres+j)-zi
4794 ! Uncomment following three lines for Ca-p interactions
4795           xj=c(1,j)-xi
4796           yj=c(2,j)-yi
4797           zj=c(3,j)-zi
4798           rij=xj*xj+yj*yj+zj*zj
4799           r0ij=r0_scp
4800           r0ijsq=r0ij*r0ij
4801           if (rij.lt.r0ijsq) then
4802             evdwij=0.25d0*(rij-r0ijsq)**2
4803             fac=rij-r0ijsq
4804           else
4805             evdwij=0.0d0
4806             fac=0.0d0
4807           endif
4808           evdw2=evdw2+evdwij
4809 !
4810 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4811 !
4812           ggg(1)=xj*fac
4813           ggg(2)=yj*fac
4814           ggg(3)=zj*fac
4815 !grad          if (j.lt.i) then
4816 !d          write (iout,*) 'j<i'
4817 ! Uncomment following three lines for SC-p interactions
4818 !           do k=1,3
4819 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4820 !           enddo
4821 !grad          else
4822 !d          write (iout,*) 'j>i'
4823 !grad            do k=1,3
4824 !grad              ggg(k)=-ggg(k)
4825 ! Uncomment following line for SC-p interactions
4826 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4827 !grad            enddo
4828 !grad          endif
4829 !grad          do k=1,3
4830 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4831 !grad          enddo
4832 !grad          kstart=min0(i+1,j)
4833 !grad          kend=max0(i-1,j-1)
4834 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4835 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4836 !grad          do k=kstart,kend
4837 !grad            do l=1,3
4838 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4839 !grad            enddo
4840 !grad          enddo
4841           do k=1,3
4842             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4843             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4844           enddo
4845         enddo
4846
4847         enddo ! iint
4848       enddo ! i
4849       return
4850       end subroutine escp_soft_sphere
4851 !-----------------------------------------------------------------------------
4852       subroutine escp(evdw2,evdw2_14)
4853 !
4854 ! This subroutine calculates the excluded-volume interaction energy between
4855 ! peptide-group centers and side chains and its gradient in virtual-bond and
4856 ! side-chain vectors.
4857 !
4858 !      implicit real*8 (a-h,o-z)
4859 !      include 'DIMENSIONS'
4860 !      include 'COMMON.GEO'
4861 !      include 'COMMON.VAR'
4862 !      include 'COMMON.LOCAL'
4863 !      include 'COMMON.CHAIN'
4864 !      include 'COMMON.DERIV'
4865 !      include 'COMMON.INTERACT'
4866 !      include 'COMMON.FFIELD'
4867 !      include 'COMMON.IOUNITS'
4868 !      include 'COMMON.CONTROL'
4869       real(kind=8),dimension(3) :: ggg
4870 !el local variables
4871       integer :: i,iint,j,k,iteli,itypj,subchap
4872       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4873                    e1,e2,evdwij,rij
4874       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4875                     dist_temp, dist_init
4876       integer xshift,yshift,zshift
4877
4878       evdw2=0.0D0
4879       evdw2_14=0.0d0
4880 !d    print '(a)','Enter ESCP'
4881 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4882       do i=iatscp_s,iatscp_e
4883         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4884         iteli=itel(i)
4885         xi=0.5D0*(c(1,i)+c(1,i+1))
4886         yi=0.5D0*(c(2,i)+c(2,i+1))
4887         zi=0.5D0*(c(3,i)+c(3,i+1))
4888           xi=mod(xi,boxxsize)
4889           if (xi.lt.0) xi=xi+boxxsize
4890           yi=mod(yi,boxysize)
4891           if (yi.lt.0) yi=yi+boxysize
4892           zi=mod(zi,boxzsize)
4893           if (zi.lt.0) zi=zi+boxzsize
4894
4895         do iint=1,nscp_gr(i)
4896
4897         do j=iscpstart(i,iint),iscpend(i,iint)
4898           itypj=iabs(itype(j,1))
4899           if (itypj.eq.ntyp1) cycle
4900 ! Uncomment following three lines for SC-p interactions
4901 !         xj=c(1,nres+j)-xi
4902 !         yj=c(2,nres+j)-yi
4903 !         zj=c(3,nres+j)-zi
4904 ! Uncomment following three lines for Ca-p interactions
4905 !          xj=c(1,j)-xi
4906 !          yj=c(2,j)-yi
4907 !          zj=c(3,j)-zi
4908           xj=c(1,j)
4909           yj=c(2,j)
4910           zj=c(3,j)
4911           xj=mod(xj,boxxsize)
4912           if (xj.lt.0) xj=xj+boxxsize
4913           yj=mod(yj,boxysize)
4914           if (yj.lt.0) yj=yj+boxysize
4915           zj=mod(zj,boxzsize)
4916           if (zj.lt.0) zj=zj+boxzsize
4917       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4918       xj_safe=xj
4919       yj_safe=yj
4920       zj_safe=zj
4921       subchap=0
4922       do xshift=-1,1
4923       do yshift=-1,1
4924       do zshift=-1,1
4925           xj=xj_safe+xshift*boxxsize
4926           yj=yj_safe+yshift*boxysize
4927           zj=zj_safe+zshift*boxzsize
4928           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4929           if(dist_temp.lt.dist_init) then
4930             dist_init=dist_temp
4931             xj_temp=xj
4932             yj_temp=yj
4933             zj_temp=zj
4934             subchap=1
4935           endif
4936        enddo
4937        enddo
4938        enddo
4939        if (subchap.eq.1) then
4940           xj=xj_temp-xi
4941           yj=yj_temp-yi
4942           zj=zj_temp-zi
4943        else
4944           xj=xj_safe-xi
4945           yj=yj_safe-yi
4946           zj=zj_safe-zi
4947        endif
4948
4949           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4950           rij=dsqrt(1.0d0/rrij)
4951             sss_ele_cut=sscale_ele(rij)
4952             sss_ele_grad=sscagrad_ele(rij)
4953 !            print *,sss_ele_cut,sss_ele_grad,&
4954 !            (rij),r_cut_ele,rlamb_ele
4955             if (sss_ele_cut.le.0.0) cycle
4956           fac=rrij**expon2
4957           e1=fac*fac*aad(itypj,iteli)
4958           e2=fac*bad(itypj,iteli)
4959           if (iabs(j-i) .le. 2) then
4960             e1=scal14*e1
4961             e2=scal14*e2
4962             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
4963           endif
4964           evdwij=e1+e2
4965           evdw2=evdw2+evdwij*sss_ele_cut
4966 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
4967 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
4968           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4969              'evdw2',i,j,evdwij
4970 !
4971 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4972 !
4973           fac=-(evdwij+e1)*rrij*sss_ele_cut
4974           fac=fac+evdwij*sss_ele_grad/rij/expon
4975           ggg(1)=xj*fac
4976           ggg(2)=yj*fac
4977           ggg(3)=zj*fac
4978 !grad          if (j.lt.i) then
4979 !d          write (iout,*) 'j<i'
4980 ! Uncomment following three lines for SC-p interactions
4981 !           do k=1,3
4982 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4983 !           enddo
4984 !grad          else
4985 !d          write (iout,*) 'j>i'
4986 !grad            do k=1,3
4987 !grad              ggg(k)=-ggg(k)
4988 ! Uncomment following line for SC-p interactions
4989 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4990 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4991 !grad            enddo
4992 !grad          endif
4993 !grad          do k=1,3
4994 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4995 !grad          enddo
4996 !grad          kstart=min0(i+1,j)
4997 !grad          kend=max0(i-1,j-1)
4998 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4999 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5000 !grad          do k=kstart,kend
5001 !grad            do l=1,3
5002 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5003 !grad            enddo
5004 !grad          enddo
5005           do k=1,3
5006             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5007             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5008           enddo
5009         enddo
5010
5011         enddo ! iint
5012       enddo ! i
5013       do i=1,nct
5014         do j=1,3
5015           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5016           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5017           gradx_scp(j,i)=expon*gradx_scp(j,i)
5018         enddo
5019       enddo
5020 !******************************************************************************
5021 !
5022 !                              N O T E !!!
5023 !
5024 ! To save time the factor EXPON has been extracted from ALL components
5025 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5026 ! use!
5027 !
5028 !******************************************************************************
5029       return
5030       end subroutine escp
5031 !-----------------------------------------------------------------------------
5032       subroutine edis(ehpb)
5033 !
5034 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5035 !
5036 !      implicit real*8 (a-h,o-z)
5037 !      include 'DIMENSIONS'
5038 !      include 'COMMON.SBRIDGE'
5039 !      include 'COMMON.CHAIN'
5040 !      include 'COMMON.DERIV'
5041 !      include 'COMMON.VAR'
5042 !      include 'COMMON.INTERACT'
5043 !      include 'COMMON.IOUNITS'
5044       real(kind=8),dimension(3) :: ggg
5045 !el local variables
5046       integer :: i,j,ii,jj,iii,jjj,k
5047       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5048
5049       ehpb=0.0D0
5050 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5051 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5052       if (link_end.eq.0) return
5053       do i=link_start,link_end
5054 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5055 ! CA-CA distance used in regularization of structure.
5056         ii=ihpb(i)
5057         jj=jhpb(i)
5058 ! iii and jjj point to the residues for which the distance is assigned.
5059         if (ii.gt.nres) then
5060           iii=ii-nres
5061           jjj=jj-nres
5062         else
5063           iii=ii
5064           jjj=jj
5065         endif
5066 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5067 !     &    dhpb(i),dhpb1(i),forcon(i)
5068 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5069 !    distance and angle dependent SS bond potential.
5070 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5071 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5072         if (.not.dyn_ss .and. i.le.nss) then
5073 ! 15/02/13 CC dynamic SSbond - additional check
5074          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5075         iabs(itype(jjj,1)).eq.1) then
5076           call ssbond_ene(iii,jjj,eij)
5077           ehpb=ehpb+2*eij
5078 !d          write (iout,*) "eij",eij
5079          endif
5080         else if (ii.gt.nres .and. jj.gt.nres) then
5081 !c Restraints from contact prediction
5082           dd=dist(ii,jj)
5083           if (constr_dist.eq.11) then
5084             ehpb=ehpb+fordepth(i)**4.0d0 &
5085                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5086             fac=fordepth(i)**4.0d0 &
5087                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5088           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5089             ehpb,fordepth(i),dd
5090            else
5091           if (dhpb1(i).gt.0.0d0) then
5092             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5093             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5094 !c            write (iout,*) "beta nmr",
5095 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5096           else
5097             dd=dist(ii,jj)
5098             rdis=dd-dhpb(i)
5099 !C Get the force constant corresponding to this distance.
5100             waga=forcon(i)
5101 !C Calculate the contribution to energy.
5102             ehpb=ehpb+waga*rdis*rdis
5103 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5104 !C
5105 !C Evaluate gradient.
5106 !C
5107             fac=waga*rdis/dd
5108           endif
5109           endif
5110           do j=1,3
5111             ggg(j)=fac*(c(j,jj)-c(j,ii))
5112           enddo
5113           do j=1,3
5114             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5115             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5116           enddo
5117           do k=1,3
5118             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5119             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5120           enddo
5121         else
5122           dd=dist(ii,jj)
5123           if (constr_dist.eq.11) then
5124             ehpb=ehpb+fordepth(i)**4.0d0 &
5125                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5126             fac=fordepth(i)**4.0d0 &
5127                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5128           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5129          ehpb,fordepth(i),dd
5130            else
5131           if (dhpb1(i).gt.0.0d0) then
5132             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5133             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5134 !c            write (iout,*) "alph nmr",
5135 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5136           else
5137             rdis=dd-dhpb(i)
5138 !C Get the force constant corresponding to this distance.
5139             waga=forcon(i)
5140 !C Calculate the contribution to energy.
5141             ehpb=ehpb+waga*rdis*rdis
5142 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5143 !C
5144 !C Evaluate gradient.
5145 !C
5146             fac=waga*rdis/dd
5147           endif
5148           endif
5149
5150             do j=1,3
5151               ggg(j)=fac*(c(j,jj)-c(j,ii))
5152             enddo
5153 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5154 !C If this is a SC-SC distance, we need to calculate the contributions to the
5155 !C Cartesian gradient in the SC vectors (ghpbx).
5156           if (iii.lt.ii) then
5157           do j=1,3
5158             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5159             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5160           enddo
5161           endif
5162 !cgrad        do j=iii,jjj-1
5163 !cgrad          do k=1,3
5164 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5165 !cgrad          enddo
5166 !cgrad        enddo
5167           do k=1,3
5168             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5169             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5170           enddo
5171         endif
5172       enddo
5173       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5174
5175       return
5176       end subroutine edis
5177 !-----------------------------------------------------------------------------
5178       subroutine ssbond_ene(i,j,eij)
5179 !
5180 ! Calculate the distance and angle dependent SS-bond potential energy
5181 ! using a free-energy function derived based on RHF/6-31G** ab initio
5182 ! calculations of diethyl disulfide.
5183 !
5184 ! A. Liwo and U. Kozlowska, 11/24/03
5185 !
5186 !      implicit real*8 (a-h,o-z)
5187 !      include 'DIMENSIONS'
5188 !      include 'COMMON.SBRIDGE'
5189 !      include 'COMMON.CHAIN'
5190 !      include 'COMMON.DERIV'
5191 !      include 'COMMON.LOCAL'
5192 !      include 'COMMON.INTERACT'
5193 !      include 'COMMON.VAR'
5194 !      include 'COMMON.IOUNITS'
5195       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5196 !el local variables
5197       integer :: i,j,itypi,itypj,k
5198       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5199                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5200                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5201                    cosphi,ggk
5202
5203       itypi=iabs(itype(i,1))
5204       xi=c(1,nres+i)
5205       yi=c(2,nres+i)
5206       zi=c(3,nres+i)
5207       dxi=dc_norm(1,nres+i)
5208       dyi=dc_norm(2,nres+i)
5209       dzi=dc_norm(3,nres+i)
5210 !      dsci_inv=dsc_inv(itypi)
5211       dsci_inv=vbld_inv(nres+i)
5212       itypj=iabs(itype(j,1))
5213 !      dscj_inv=dsc_inv(itypj)
5214       dscj_inv=vbld_inv(nres+j)
5215       xj=c(1,nres+j)-xi
5216       yj=c(2,nres+j)-yi
5217       zj=c(3,nres+j)-zi
5218       dxj=dc_norm(1,nres+j)
5219       dyj=dc_norm(2,nres+j)
5220       dzj=dc_norm(3,nres+j)
5221       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5222       rij=dsqrt(rrij)
5223       erij(1)=xj*rij
5224       erij(2)=yj*rij
5225       erij(3)=zj*rij
5226       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5227       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5228       om12=dxi*dxj+dyi*dyj+dzi*dzj
5229       do k=1,3
5230         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5231         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5232       enddo
5233       rij=1.0d0/rij
5234       deltad=rij-d0cm
5235       deltat1=1.0d0-om1
5236       deltat2=1.0d0+om2
5237       deltat12=om2-om1+2.0d0
5238       cosphi=om12-om1*om2
5239       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5240         +akct*deltad*deltat12 &
5241         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5242 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5243 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5244 !     &  " deltat12",deltat12," eij",eij
5245       ed=2*akcm*deltad+akct*deltat12
5246       pom1=akct*deltad
5247       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5248       eom1=-2*akth*deltat1-pom1-om2*pom2
5249       eom2= 2*akth*deltat2+pom1-om1*pom2
5250       eom12=pom2
5251       do k=1,3
5252         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5253         ghpbx(k,i)=ghpbx(k,i)-ggk &
5254                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5255                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5256         ghpbx(k,j)=ghpbx(k,j)+ggk &
5257                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5258                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5259         ghpbc(k,i)=ghpbc(k,i)-ggk
5260         ghpbc(k,j)=ghpbc(k,j)+ggk
5261       enddo
5262 !
5263 ! Calculate the components of the gradient in DC and X
5264 !
5265 !grad      do k=i,j-1
5266 !grad        do l=1,3
5267 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5268 !grad        enddo
5269 !grad      enddo
5270       return
5271       end subroutine ssbond_ene
5272 !-----------------------------------------------------------------------------
5273       subroutine ebond(estr)
5274 !
5275 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5276 !
5277 !      implicit real*8 (a-h,o-z)
5278 !      include 'DIMENSIONS'
5279 !      include 'COMMON.LOCAL'
5280 !      include 'COMMON.GEO'
5281 !      include 'COMMON.INTERACT'
5282 !      include 'COMMON.DERIV'
5283 !      include 'COMMON.VAR'
5284 !      include 'COMMON.CHAIN'
5285 !      include 'COMMON.IOUNITS'
5286 !      include 'COMMON.NAMES'
5287 !      include 'COMMON.FFIELD'
5288 !      include 'COMMON.CONTROL'
5289 !      include 'COMMON.SETUP'
5290       real(kind=8),dimension(3) :: u,ud
5291 !el local variables
5292       integer :: i,j,iti,nbi,k
5293       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5294                    uprod1,uprod2
5295
5296       estr=0.0d0
5297       estr1=0.0d0
5298 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5299 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5300
5301       do i=ibondp_start,ibondp_end
5302         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5303         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5304 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5305 !C          do j=1,3
5306 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5307 !C            *dc(j,i-1)/vbld(i)
5308 !C          enddo
5309 !C          if (energy_dec) write(iout,*) &
5310 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5311         diff = vbld(i)-vbldpDUM
5312         else
5313         diff = vbld(i)-vbldp0
5314         endif
5315         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5316            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5317         estr=estr+diff*diff
5318         do j=1,3
5319           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5320         enddo
5321 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5322 !        endif
5323       enddo
5324       estr=0.5d0*AKP*estr+estr1
5325 !      print *,"estr_bb",estr,AKP
5326 !
5327 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5328 !
5329       do i=ibond_start,ibond_end
5330         iti=iabs(itype(i,1))
5331         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5332         if (iti.ne.10 .and. iti.ne.ntyp1) then
5333           nbi=nbondterm(iti)
5334           if (nbi.eq.1) then
5335             diff=vbld(i+nres)-vbldsc0(1,iti)
5336             if (energy_dec) write (iout,*) &
5337             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5338             AKSC(1,iti),AKSC(1,iti)*diff*diff
5339             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5340 !            print *,"estr_sc",estr
5341             do j=1,3
5342               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5343             enddo
5344           else
5345             do j=1,nbi
5346               diff=vbld(i+nres)-vbldsc0(j,iti)
5347               ud(j)=aksc(j,iti)*diff
5348               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5349             enddo
5350             uprod=u(1)
5351             do j=2,nbi
5352               uprod=uprod*u(j)
5353             enddo
5354             usum=0.0d0
5355             usumsqder=0.0d0
5356             do j=1,nbi
5357               uprod1=1.0d0
5358               uprod2=1.0d0
5359               do k=1,nbi
5360                 if (k.ne.j) then
5361                   uprod1=uprod1*u(k)
5362                   uprod2=uprod2*u(k)*u(k)
5363                 endif
5364               enddo
5365               usum=usum+uprod1
5366               usumsqder=usumsqder+ud(j)*uprod2
5367             enddo
5368             estr=estr+uprod/usum
5369 !            print *,"estr_sc",estr,i
5370
5371              if (energy_dec) write (iout,*) &
5372             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5373             AKSC(1,iti),uprod/usum
5374             do j=1,3
5375              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5376             enddo
5377           endif
5378         endif
5379       enddo
5380       return
5381       end subroutine ebond
5382 #ifdef CRYST_THETA
5383 !-----------------------------------------------------------------------------
5384       subroutine ebend(etheta)
5385 !
5386 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5387 ! angles gamma and its derivatives in consecutive thetas and gammas.
5388 !
5389       use comm_calcthet
5390 !      implicit real*8 (a-h,o-z)
5391 !      include 'DIMENSIONS'
5392 !      include 'COMMON.LOCAL'
5393 !      include 'COMMON.GEO'
5394 !      include 'COMMON.INTERACT'
5395 !      include 'COMMON.DERIV'
5396 !      include 'COMMON.VAR'
5397 !      include 'COMMON.CHAIN'
5398 !      include 'COMMON.IOUNITS'
5399 !      include 'COMMON.NAMES'
5400 !      include 'COMMON.FFIELD'
5401 !      include 'COMMON.CONTROL'
5402 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5403 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5404 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5405 !el      integer :: it
5406 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5407 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5408 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5409 !el local variables
5410       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5411        ichir21,ichir22
5412       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5413        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5414        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5415       real(kind=8),dimension(2) :: y,z
5416
5417       delta=0.02d0*pi
5418 !      time11=dexp(-2*time)
5419 !      time12=1.0d0
5420       etheta=0.0D0
5421 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5422       do i=ithet_start,ithet_end
5423         if (itype(i-1,1).eq.ntyp1) cycle
5424 ! Zero the energy function and its derivative at 0 or pi.
5425         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5426         it=itype(i-1,1)
5427         ichir1=isign(1,itype(i-2,1))
5428         ichir2=isign(1,itype(i,1))
5429          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5430          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5431          if (itype(i-1,1).eq.10) then
5432           itype1=isign(10,itype(i-2,1))
5433           ichir11=isign(1,itype(i-2,1))
5434           ichir12=isign(1,itype(i-2,1))
5435           itype2=isign(10,itype(i,1))
5436           ichir21=isign(1,itype(i,1))
5437           ichir22=isign(1,itype(i,1))
5438          endif
5439
5440         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5441 #ifdef OSF
5442           phii=phi(i)
5443           if (phii.ne.phii) phii=150.0
5444 #else
5445           phii=phi(i)
5446 #endif
5447           y(1)=dcos(phii)
5448           y(2)=dsin(phii)
5449         else
5450           y(1)=0.0D0
5451           y(2)=0.0D0
5452         endif
5453         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5454 #ifdef OSF
5455           phii1=phi(i+1)
5456           if (phii1.ne.phii1) phii1=150.0
5457           phii1=pinorm(phii1)
5458           z(1)=cos(phii1)
5459 #else
5460           phii1=phi(i+1)
5461           z(1)=dcos(phii1)
5462 #endif
5463           z(2)=dsin(phii1)
5464         else
5465           z(1)=0.0D0
5466           z(2)=0.0D0
5467         endif
5468 ! Calculate the "mean" value of theta from the part of the distribution
5469 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5470 ! In following comments this theta will be referred to as t_c.
5471         thet_pred_mean=0.0d0
5472         do k=1,2
5473             athetk=athet(k,it,ichir1,ichir2)
5474             bthetk=bthet(k,it,ichir1,ichir2)
5475           if (it.eq.10) then
5476              athetk=athet(k,itype1,ichir11,ichir12)
5477              bthetk=bthet(k,itype2,ichir21,ichir22)
5478           endif
5479          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5480         enddo
5481         dthett=thet_pred_mean*ssd
5482         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5483 ! Derivatives of the "mean" values in gamma1 and gamma2.
5484         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5485                +athet(2,it,ichir1,ichir2)*y(1))*ss
5486         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5487                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5488          if (it.eq.10) then
5489         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5490              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5491         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5492                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5493          endif
5494         if (theta(i).gt.pi-delta) then
5495           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5496                E_tc0)
5497           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5498           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5499           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5500               E_theta)
5501           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5502               E_tc)
5503         else if (theta(i).lt.delta) then
5504           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5505           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5506           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5507               E_theta)
5508           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5509           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5510               E_tc)
5511         else
5512           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5513               E_theta,E_tc)
5514         endif
5515         etheta=etheta+ethetai
5516         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5517             'ebend',i,ethetai
5518         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5519         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5520         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5521       enddo
5522 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5523
5524 ! Ufff.... We've done all this!!!
5525       return
5526       end subroutine ebend
5527 !-----------------------------------------------------------------------------
5528       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5529
5530       use comm_calcthet
5531 !      implicit real*8 (a-h,o-z)
5532 !      include 'DIMENSIONS'
5533 !      include 'COMMON.LOCAL'
5534 !      include 'COMMON.IOUNITS'
5535 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5536 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5537 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5538       integer :: i,j,k
5539       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5540 !el      integer :: it
5541 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5542 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5543 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5544 !el local variables
5545       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5546        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5547
5548 ! Calculate the contributions to both Gaussian lobes.
5549 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5550 ! The "polynomial part" of the "standard deviation" of this part of
5551 ! the distribution.
5552         sig=polthet(3,it)
5553         do j=2,0,-1
5554           sig=sig*thet_pred_mean+polthet(j,it)
5555         enddo
5556 ! Derivative of the "interior part" of the "standard deviation of the"
5557 ! gamma-dependent Gaussian lobe in t_c.
5558         sigtc=3*polthet(3,it)
5559         do j=2,1,-1
5560           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5561         enddo
5562         sigtc=sig*sigtc
5563 ! Set the parameters of both Gaussian lobes of the distribution.
5564 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5565         fac=sig*sig+sigc0(it)
5566         sigcsq=fac+fac
5567         sigc=1.0D0/sigcsq
5568 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5569         sigsqtc=-4.0D0*sigcsq*sigtc
5570 !       print *,i,sig,sigtc,sigsqtc
5571 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5572         sigtc=-sigtc/(fac*fac)
5573 ! Following variable is sigma(t_c)**(-2)
5574         sigcsq=sigcsq*sigcsq
5575         sig0i=sig0(it)
5576         sig0inv=1.0D0/sig0i**2
5577         delthec=thetai-thet_pred_mean
5578         delthe0=thetai-theta0i
5579         term1=-0.5D0*sigcsq*delthec*delthec
5580         term2=-0.5D0*sig0inv*delthe0*delthe0
5581 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5582 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5583 ! to the energy (this being the log of the distribution) at the end of energy
5584 ! term evaluation for this virtual-bond angle.
5585         if (term1.gt.term2) then
5586           termm=term1
5587           term2=dexp(term2-termm)
5588           term1=1.0d0
5589         else
5590           termm=term2
5591           term1=dexp(term1-termm)
5592           term2=1.0d0
5593         endif
5594 ! The ratio between the gamma-independent and gamma-dependent lobes of
5595 ! the distribution is a Gaussian function of thet_pred_mean too.
5596         diffak=gthet(2,it)-thet_pred_mean
5597         ratak=diffak/gthet(3,it)**2
5598         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5599 ! Let's differentiate it in thet_pred_mean NOW.
5600         aktc=ak*ratak
5601 ! Now put together the distribution terms to make complete distribution.
5602         termexp=term1+ak*term2
5603         termpre=sigc+ak*sig0i
5604 ! Contribution of the bending energy from this theta is just the -log of
5605 ! the sum of the contributions from the two lobes and the pre-exponential
5606 ! factor. Simple enough, isn't it?
5607         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5608 ! NOW the derivatives!!!
5609 ! 6/6/97 Take into account the deformation.
5610         E_theta=(delthec*sigcsq*term1 &
5611              +ak*delthe0*sig0inv*term2)/termexp
5612         E_tc=((sigtc+aktc*sig0i)/termpre &
5613             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5614              aktc*term2)/termexp)
5615       return
5616       end subroutine theteng
5617 #else
5618 !-----------------------------------------------------------------------------
5619       subroutine ebend(etheta,ethetacnstr)
5620 !
5621 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5622 ! angles gamma and its derivatives in consecutive thetas and gammas.
5623 ! ab initio-derived potentials from
5624 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5625 !
5626 !      implicit real*8 (a-h,o-z)
5627 !      include 'DIMENSIONS'
5628 !      include 'COMMON.LOCAL'
5629 !      include 'COMMON.GEO'
5630 !      include 'COMMON.INTERACT'
5631 !      include 'COMMON.DERIV'
5632 !      include 'COMMON.VAR'
5633 !      include 'COMMON.CHAIN'
5634 !      include 'COMMON.IOUNITS'
5635 !      include 'COMMON.NAMES'
5636 !      include 'COMMON.FFIELD'
5637 !      include 'COMMON.CONTROL'
5638       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5639       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5640       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5641       logical :: lprn=.false., lprn1=.false.
5642 !el local variables
5643       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5644       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5645       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5646 ! local variables for constrains
5647       real(kind=8) :: difi,thetiii
5648        integer itheta
5649
5650       etheta=0.0D0
5651       do i=ithet_start,ithet_end
5652         if (itype(i-1,1).eq.ntyp1) cycle
5653         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5654         if (iabs(itype(i+1,1)).eq.20) iblock=2
5655         if (iabs(itype(i+1,1)).ne.20) iblock=1
5656         dethetai=0.0d0
5657         dephii=0.0d0
5658         dephii1=0.0d0
5659         theti2=0.5d0*theta(i)
5660         ityp2=ithetyp((itype(i-1,1)))
5661         do k=1,nntheterm
5662           coskt(k)=dcos(k*theti2)
5663           sinkt(k)=dsin(k*theti2)
5664         enddo
5665         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5666 #ifdef OSF
5667           phii=phi(i)
5668           if (phii.ne.phii) phii=150.0
5669 #else
5670           phii=phi(i)
5671 #endif
5672           ityp1=ithetyp((itype(i-2,1)))
5673 ! propagation of chirality for glycine type
5674           do k=1,nsingle
5675             cosph1(k)=dcos(k*phii)
5676             sinph1(k)=dsin(k*phii)
5677           enddo
5678         else
5679           phii=0.0d0
5680           ityp1=ithetyp(itype(i-2,1))
5681           do k=1,nsingle
5682             cosph1(k)=0.0d0
5683             sinph1(k)=0.0d0
5684           enddo
5685         endif
5686         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5687 #ifdef OSF
5688           phii1=phi(i+1)
5689           if (phii1.ne.phii1) phii1=150.0
5690           phii1=pinorm(phii1)
5691 #else
5692           phii1=phi(i+1)
5693 #endif
5694           ityp3=ithetyp((itype(i,1)))
5695           do k=1,nsingle
5696             cosph2(k)=dcos(k*phii1)
5697             sinph2(k)=dsin(k*phii1)
5698           enddo
5699         else
5700           phii1=0.0d0
5701           ityp3=ithetyp(itype(i,1))
5702           do k=1,nsingle
5703             cosph2(k)=0.0d0
5704             sinph2(k)=0.0d0
5705           enddo
5706         endif
5707         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5708         do k=1,ndouble
5709           do l=1,k-1
5710             ccl=cosph1(l)*cosph2(k-l)
5711             ssl=sinph1(l)*sinph2(k-l)
5712             scl=sinph1(l)*cosph2(k-l)
5713             csl=cosph1(l)*sinph2(k-l)
5714             cosph1ph2(l,k)=ccl-ssl
5715             cosph1ph2(k,l)=ccl+ssl
5716             sinph1ph2(l,k)=scl+csl
5717             sinph1ph2(k,l)=scl-csl
5718           enddo
5719         enddo
5720         if (lprn) then
5721         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5722           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5723         write (iout,*) "coskt and sinkt"
5724         do k=1,nntheterm
5725           write (iout,*) k,coskt(k),sinkt(k)
5726         enddo
5727         endif
5728         do k=1,ntheterm
5729           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5730           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5731             *coskt(k)
5732           if (lprn) &
5733           write (iout,*) "k",k,&
5734            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5735            " ethetai",ethetai
5736         enddo
5737         if (lprn) then
5738         write (iout,*) "cosph and sinph"
5739         do k=1,nsingle
5740           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5741         enddo
5742         write (iout,*) "cosph1ph2 and sinph2ph2"
5743         do k=2,ndouble
5744           do l=1,k-1
5745             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5746                sinph1ph2(l,k),sinph1ph2(k,l)
5747           enddo
5748         enddo
5749         write(iout,*) "ethetai",ethetai
5750         endif
5751         do m=1,ntheterm2
5752           do k=1,nsingle
5753             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5754                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5755                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5756                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5757             ethetai=ethetai+sinkt(m)*aux
5758             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5759             dephii=dephii+k*sinkt(m)* &
5760                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5761                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5762             dephii1=dephii1+k*sinkt(m)* &
5763                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5764                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5765             if (lprn) &
5766             write (iout,*) "m",m," k",k," bbthet", &
5767                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5768                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5769                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5770                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5771           enddo
5772         enddo
5773         if (lprn) &
5774         write(iout,*) "ethetai",ethetai
5775         do m=1,ntheterm3
5776           do k=2,ndouble
5777             do l=1,k-1
5778               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5779                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5780                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5781                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5782               ethetai=ethetai+sinkt(m)*aux
5783               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5784               dephii=dephii+l*sinkt(m)* &
5785                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5786                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5787                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5788                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5789               dephii1=dephii1+(k-l)*sinkt(m)* &
5790                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5791                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5792                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5793                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5794               if (lprn) then
5795               write (iout,*) "m",m," k",k," l",l," ffthet",&
5796                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5797                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5798                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5799                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5800                   " ethetai",ethetai
5801               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5802                   cosph1ph2(k,l)*sinkt(m),&
5803                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5804               endif
5805             enddo
5806           enddo
5807         enddo
5808 10      continue
5809 !        lprn1=.true.
5810         if (lprn1) &
5811           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5812          i,theta(i)*rad2deg,phii*rad2deg,&
5813          phii1*rad2deg,ethetai
5814 !        lprn1=.false.
5815         etheta=etheta+ethetai
5816         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5817                                     'ebend',i,ethetai
5818         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5819         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5820         gloc(nphi+i-2,icg)=wang*dethetai
5821       enddo
5822 !-----------thete constrains
5823 !      if (tor_mode.ne.2) then
5824       ethetacnstr=0.0d0
5825 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5826       do i=ithetaconstr_start,ithetaconstr_end
5827         itheta=itheta_constr(i)
5828         thetiii=theta(itheta)
5829         difi=pinorm(thetiii-theta_constr0(i))
5830         if (difi.gt.theta_drange(i)) then
5831           difi=difi-theta_drange(i)
5832           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5833           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5834          +for_thet_constr(i)*difi**3
5835         else if (difi.lt.-drange(i)) then
5836           difi=difi+drange(i)
5837           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5838           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5839          +for_thet_constr(i)*difi**3
5840         else
5841           difi=0.0
5842         endif
5843        if (energy_dec) then
5844         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5845          i,itheta,rad2deg*thetiii, &
5846          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5847          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5848          gloc(itheta+nphi-2,icg)
5849         endif
5850       enddo
5851 !      endif
5852
5853       return
5854       end subroutine ebend
5855 #endif
5856 #ifdef CRYST_SC
5857 !-----------------------------------------------------------------------------
5858       subroutine esc(escloc)
5859 ! Calculate the local energy of a side chain and its derivatives in the
5860 ! corresponding virtual-bond valence angles THETA and the spherical angles
5861 ! ALPHA and OMEGA.
5862 !
5863       use comm_sccalc
5864 !      implicit real*8 (a-h,o-z)
5865 !      include 'DIMENSIONS'
5866 !      include 'COMMON.GEO'
5867 !      include 'COMMON.LOCAL'
5868 !      include 'COMMON.VAR'
5869 !      include 'COMMON.INTERACT'
5870 !      include 'COMMON.DERIV'
5871 !      include 'COMMON.CHAIN'
5872 !      include 'COMMON.IOUNITS'
5873 !      include 'COMMON.NAMES'
5874 !      include 'COMMON.FFIELD'
5875 !      include 'COMMON.CONTROL'
5876       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5877          ddersc0,ddummy,xtemp,temp
5878 !el      real(kind=8) :: time11,time12,time112,theti
5879       real(kind=8) :: escloc,delta
5880 !el      integer :: it,nlobit
5881 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5882 !el local variables
5883       integer :: i,k
5884       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5885        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5886       delta=0.02d0*pi
5887       escloc=0.0D0
5888 !     write (iout,'(a)') 'ESC'
5889       do i=loc_start,loc_end
5890         it=itype(i,1)
5891         if (it.eq.ntyp1) cycle
5892         if (it.eq.10) goto 1
5893         nlobit=nlob(iabs(it))
5894 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5895 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5896         theti=theta(i+1)-pipol
5897         x(1)=dtan(theti)
5898         x(2)=alph(i)
5899         x(3)=omeg(i)
5900
5901         if (x(2).gt.pi-delta) then
5902           xtemp(1)=x(1)
5903           xtemp(2)=pi-delta
5904           xtemp(3)=x(3)
5905           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5906           xtemp(2)=pi
5907           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5908           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5909               escloci,dersc(2))
5910           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5911               ddersc0(1),dersc(1))
5912           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5913               ddersc0(3),dersc(3))
5914           xtemp(2)=pi-delta
5915           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5916           xtemp(2)=pi
5917           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5918           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5919                   dersc0(2),esclocbi,dersc02)
5920           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5921                   dersc12,dersc01)
5922           call splinthet(x(2),0.5d0*delta,ss,ssd)
5923           dersc0(1)=dersc01
5924           dersc0(2)=dersc02
5925           dersc0(3)=0.0d0
5926           do k=1,3
5927             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5928           enddo
5929           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5930 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5931 !    &             esclocbi,ss,ssd
5932           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5933 !         escloci=esclocbi
5934 !         write (iout,*) escloci
5935         else if (x(2).lt.delta) then
5936           xtemp(1)=x(1)
5937           xtemp(2)=delta
5938           xtemp(3)=x(3)
5939           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5940           xtemp(2)=0.0d0
5941           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5942           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
5943               escloci,dersc(2))
5944           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5945               ddersc0(1),dersc(1))
5946           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
5947               ddersc0(3),dersc(3))
5948           xtemp(2)=delta
5949           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5950           xtemp(2)=0.0d0
5951           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5952           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
5953                   dersc0(2),esclocbi,dersc02)
5954           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5955                   dersc12,dersc01)
5956           dersc0(1)=dersc01
5957           dersc0(2)=dersc02
5958           dersc0(3)=0.0d0
5959           call splinthet(x(2),0.5d0*delta,ss,ssd)
5960           do k=1,3
5961             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5962           enddo
5963           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5964 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5965 !    &             esclocbi,ss,ssd
5966           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5967 !         write (iout,*) escloci
5968         else
5969           call enesc(x,escloci,dersc,ddummy,.false.)
5970         endif
5971
5972         escloc=escloc+escloci
5973         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5974            'escloc',i,escloci
5975 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5976
5977         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
5978          wscloc*dersc(1)
5979         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5980         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5981     1   continue
5982       enddo
5983       return
5984       end subroutine esc
5985 !-----------------------------------------------------------------------------
5986       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5987
5988       use comm_sccalc
5989 !      implicit real*8 (a-h,o-z)
5990 !      include 'DIMENSIONS'
5991 !      include 'COMMON.GEO'
5992 !      include 'COMMON.LOCAL'
5993 !      include 'COMMON.IOUNITS'
5994 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5995       real(kind=8),dimension(3) :: x,z,dersc,ddersc
5996       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
5997       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
5998       real(kind=8) :: escloci
5999       logical :: mixed
6000 !el local variables
6001       integer :: j,iii,l,k !el,it,nlobit
6002       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6003 !el       time11,time12,time112
6004 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6005         escloc_i=0.0D0
6006         do j=1,3
6007           dersc(j)=0.0D0
6008           if (mixed) ddersc(j)=0.0d0
6009         enddo
6010         x3=x(3)
6011
6012 ! Because of periodicity of the dependence of the SC energy in omega we have
6013 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6014 ! To avoid underflows, first compute & store the exponents.
6015
6016         do iii=-1,1
6017
6018           x(3)=x3+iii*dwapi
6019
6020           do j=1,nlobit
6021             do k=1,3
6022               z(k)=x(k)-censc(k,j,it)
6023             enddo
6024             do k=1,3
6025               Axk=0.0D0
6026               do l=1,3
6027                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6028               enddo
6029               Ax(k,j,iii)=Axk
6030             enddo
6031             expfac=0.0D0
6032             do k=1,3
6033               expfac=expfac+Ax(k,j,iii)*z(k)
6034             enddo
6035             contr(j,iii)=expfac
6036           enddo ! j
6037
6038         enddo ! iii
6039
6040         x(3)=x3
6041 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6042 ! subsequent NaNs and INFs in energy calculation.
6043 ! Find the largest exponent
6044         emin=contr(1,-1)
6045         do iii=-1,1
6046           do j=1,nlobit
6047             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6048           enddo
6049         enddo
6050         emin=0.5D0*emin
6051 !d      print *,'it=',it,' emin=',emin
6052
6053 ! Compute the contribution to SC energy and derivatives
6054         do iii=-1,1
6055
6056           do j=1,nlobit
6057 #ifdef OSF
6058             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6059             if(adexp.ne.adexp) adexp=1.0
6060             expfac=dexp(adexp)
6061 #else
6062             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6063 #endif
6064 !d          print *,'j=',j,' expfac=',expfac
6065             escloc_i=escloc_i+expfac
6066             do k=1,3
6067               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6068             enddo
6069             if (mixed) then
6070               do k=1,3,2
6071                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6072                   +gaussc(k,2,j,it))*expfac
6073               enddo
6074             endif
6075           enddo
6076
6077         enddo ! iii
6078
6079         dersc(1)=dersc(1)/cos(theti)**2
6080         ddersc(1)=ddersc(1)/cos(theti)**2
6081         ddersc(3)=ddersc(3)
6082
6083         escloci=-(dlog(escloc_i)-emin)
6084         do j=1,3
6085           dersc(j)=dersc(j)/escloc_i
6086         enddo
6087         if (mixed) then
6088           do j=1,3,2
6089             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6090           enddo
6091         endif
6092       return
6093       end subroutine enesc
6094 !-----------------------------------------------------------------------------
6095       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6096
6097       use comm_sccalc
6098 !      implicit real*8 (a-h,o-z)
6099 !      include 'DIMENSIONS'
6100 !      include 'COMMON.GEO'
6101 !      include 'COMMON.LOCAL'
6102 !      include 'COMMON.IOUNITS'
6103 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6104       real(kind=8),dimension(3) :: x,z,dersc
6105       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6106       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6107       real(kind=8) :: escloci,dersc12,emin
6108       logical :: mixed
6109 !el local varables
6110       integer :: j,k,l !el,it,nlobit
6111       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6112
6113       escloc_i=0.0D0
6114
6115       do j=1,3
6116         dersc(j)=0.0D0
6117       enddo
6118
6119       do j=1,nlobit
6120         do k=1,2
6121           z(k)=x(k)-censc(k,j,it)
6122         enddo
6123         z(3)=dwapi
6124         do k=1,3
6125           Axk=0.0D0
6126           do l=1,3
6127             Axk=Axk+gaussc(l,k,j,it)*z(l)
6128           enddo
6129           Ax(k,j)=Axk
6130         enddo
6131         expfac=0.0D0
6132         do k=1,3
6133           expfac=expfac+Ax(k,j)*z(k)
6134         enddo
6135         contr(j)=expfac
6136       enddo ! j
6137
6138 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6139 ! subsequent NaNs and INFs in energy calculation.
6140 ! Find the largest exponent
6141       emin=contr(1)
6142       do j=1,nlobit
6143         if (emin.gt.contr(j)) emin=contr(j)
6144       enddo
6145       emin=0.5D0*emin
6146
6147 ! Compute the contribution to SC energy and derivatives
6148
6149       dersc12=0.0d0
6150       do j=1,nlobit
6151         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6152         escloc_i=escloc_i+expfac
6153         do k=1,2
6154           dersc(k)=dersc(k)+Ax(k,j)*expfac
6155         enddo
6156         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6157                   +gaussc(1,2,j,it))*expfac
6158         dersc(3)=0.0d0
6159       enddo
6160
6161       dersc(1)=dersc(1)/cos(theti)**2
6162       dersc12=dersc12/cos(theti)**2
6163       escloci=-(dlog(escloc_i)-emin)
6164       do j=1,2
6165         dersc(j)=dersc(j)/escloc_i
6166       enddo
6167       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6168       return
6169       end subroutine enesc_bound
6170 #else
6171 !-----------------------------------------------------------------------------
6172       subroutine esc(escloc)
6173 ! Calculate the local energy of a side chain and its derivatives in the
6174 ! corresponding virtual-bond valence angles THETA and the spherical angles
6175 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6176 ! added by Urszula Kozlowska. 07/11/2007
6177 !
6178       use comm_sccalc
6179 !      implicit real*8 (a-h,o-z)
6180 !      include 'DIMENSIONS'
6181 !      include 'COMMON.GEO'
6182 !      include 'COMMON.LOCAL'
6183 !      include 'COMMON.VAR'
6184 !      include 'COMMON.SCROT'
6185 !      include 'COMMON.INTERACT'
6186 !      include 'COMMON.DERIV'
6187 !      include 'COMMON.CHAIN'
6188 !      include 'COMMON.IOUNITS'
6189 !      include 'COMMON.NAMES'
6190 !      include 'COMMON.FFIELD'
6191 !      include 'COMMON.CONTROL'
6192 !      include 'COMMON.VECTORS'
6193       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6194       real(kind=8),dimension(65) :: x
6195       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6196          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6197       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6198       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6199          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6200 !el local variables
6201       integer :: i,j,k !el,it,nlobit
6202       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6203 !el      real(kind=8) :: time11,time12,time112,theti
6204 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6205       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6206                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6207                    sumene1x,sumene2x,sumene3x,sumene4x,&
6208                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6209                    cosfac2xx,sinfac2yy
6210 #ifdef DEBUG
6211       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6212                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6213                    de_dt_num
6214 #endif
6215 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6216
6217       delta=0.02d0*pi
6218       escloc=0.0D0
6219       do i=loc_start,loc_end
6220         if (itype(i,1).eq.ntyp1) cycle
6221         costtab(i+1) =dcos(theta(i+1))
6222         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6223         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6224         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6225         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6226         cosfac=dsqrt(cosfac2)
6227         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6228         sinfac=dsqrt(sinfac2)
6229         it=iabs(itype(i,1))
6230         if (it.eq.10) goto 1
6231 !
6232 !  Compute the axes of tghe local cartesian coordinates system; store in
6233 !   x_prime, y_prime and z_prime
6234 !
6235         do j=1,3
6236           x_prime(j) = 0.00
6237           y_prime(j) = 0.00
6238           z_prime(j) = 0.00
6239         enddo
6240 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6241 !     &   dc_norm(3,i+nres)
6242         do j = 1,3
6243           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6244           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6245         enddo
6246         do j = 1,3
6247           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6248         enddo
6249 !       write (2,*) "i",i
6250 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6251 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6252 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6253 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6254 !      & " xy",scalar(x_prime(1),y_prime(1)),
6255 !      & " xz",scalar(x_prime(1),z_prime(1)),
6256 !      & " yy",scalar(y_prime(1),y_prime(1)),
6257 !      & " yz",scalar(y_prime(1),z_prime(1)),
6258 !      & " zz",scalar(z_prime(1),z_prime(1))
6259 !
6260 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6261 ! to local coordinate system. Store in xx, yy, zz.
6262 !
6263         xx=0.0d0
6264         yy=0.0d0
6265         zz=0.0d0
6266         do j = 1,3
6267           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6268           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6269           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6270         enddo
6271
6272         xxtab(i)=xx
6273         yytab(i)=yy
6274         zztab(i)=zz
6275 !
6276 ! Compute the energy of the ith side cbain
6277 !
6278 !        write (2,*) "xx",xx," yy",yy," zz",zz
6279         it=iabs(itype(i,1))
6280         do j = 1,65
6281           x(j) = sc_parmin(j,it)
6282         enddo
6283 #ifdef CHECK_COORD
6284 !c diagnostics - remove later
6285         xx1 = dcos(alph(2))
6286         yy1 = dsin(alph(2))*dcos(omeg(2))
6287         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6288         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6289           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6290           xx1,yy1,zz1
6291 !,"  --- ", xx_w,yy_w,zz_w
6292 ! end diagnostics
6293 #endif
6294         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6295          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6296          + x(10)*yy*zz
6297         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6298          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6299          + x(20)*yy*zz
6300         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6301          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6302          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6303          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6304          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6305          +x(40)*xx*yy*zz
6306         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6307          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6308          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6309          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6310          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6311          +x(60)*xx*yy*zz
6312         dsc_i   = 0.743d0+x(61)
6313         dp2_i   = 1.9d0+x(62)
6314         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6315                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6316         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6317                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6318         s1=(1+x(63))/(0.1d0 + dscp1)
6319         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6320         s2=(1+x(65))/(0.1d0 + dscp2)
6321         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6322         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6323       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6324 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6325 !     &   sumene4,
6326 !     &   dscp1,dscp2,sumene
6327 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6328         escloc = escloc + sumene
6329 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6330 !     & ,zz,xx,yy
6331 !#define DEBUG
6332 #ifdef DEBUG
6333 !
6334 ! This section to check the numerical derivatives of the energy of ith side
6335 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6336 ! #define DEBUG in the code to turn it on.
6337 !
6338         write (2,*) "sumene               =",sumene
6339         aincr=1.0d-7
6340         xxsave=xx
6341         xx=xx+aincr
6342         write (2,*) xx,yy,zz
6343         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6344         de_dxx_num=(sumenep-sumene)/aincr
6345         xx=xxsave
6346         write (2,*) "xx+ sumene from enesc=",sumenep
6347         yysave=yy
6348         yy=yy+aincr
6349         write (2,*) xx,yy,zz
6350         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6351         de_dyy_num=(sumenep-sumene)/aincr
6352         yy=yysave
6353         write (2,*) "yy+ sumene from enesc=",sumenep
6354         zzsave=zz
6355         zz=zz+aincr
6356         write (2,*) xx,yy,zz
6357         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6358         de_dzz_num=(sumenep-sumene)/aincr
6359         zz=zzsave
6360         write (2,*) "zz+ sumene from enesc=",sumenep
6361         costsave=cost2tab(i+1)
6362         sintsave=sint2tab(i+1)
6363         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6364         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6365         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6366         de_dt_num=(sumenep-sumene)/aincr
6367         write (2,*) " t+ sumene from enesc=",sumenep
6368         cost2tab(i+1)=costsave
6369         sint2tab(i+1)=sintsave
6370 ! End of diagnostics section.
6371 #endif
6372 !
6373 ! Compute the gradient of esc
6374 !
6375 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6376         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6377         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6378         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6379         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6380         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6381         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6382         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6383         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6384         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6385            *(pom_s1/dscp1+pom_s16*dscp1**4)
6386         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6387            *(pom_s2/dscp2+pom_s26*dscp2**4)
6388         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6389         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6390         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6391         +x(40)*yy*zz
6392         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6393         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6394         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6395         +x(60)*yy*zz
6396         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6397               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6398               +(pom1+pom2)*pom_dx
6399 #ifdef DEBUG
6400         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6401 #endif
6402 !
6403         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6404         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6405         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6406         +x(40)*xx*zz
6407         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6408         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6409         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6410         +x(59)*zz**2 +x(60)*xx*zz
6411         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6412               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6413               +(pom1-pom2)*pom_dy
6414 #ifdef DEBUG
6415         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6416 #endif
6417 !
6418         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6419         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6420         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6421         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6422         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6423         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6424         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6425         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6426 #ifdef DEBUG
6427         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6428 #endif
6429 !
6430         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6431         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6432         +pom1*pom_dt1+pom2*pom_dt2
6433 #ifdef DEBUG
6434         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6435 #endif
6436 !
6437 !
6438        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6439        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6440        cosfac2xx=cosfac2*xx
6441        sinfac2yy=sinfac2*yy
6442        do k = 1,3
6443          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6444             vbld_inv(i+1)
6445          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6446             vbld_inv(i)
6447          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6448          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6449 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6450 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6451 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6452 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6453          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6454          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6455          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6456          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6457          dZZ_Ci1(k)=0.0d0
6458          dZZ_Ci(k)=0.0d0
6459          do j=1,3
6460            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6461            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6462            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6463            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6464          enddo
6465
6466          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6467          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6468          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6469          (z_prime(k)-zz*dC_norm(k,i+nres))
6470 !
6471          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6472          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6473        enddo
6474
6475        do k=1,3
6476          dXX_Ctab(k,i)=dXX_Ci(k)
6477          dXX_C1tab(k,i)=dXX_Ci1(k)
6478          dYY_Ctab(k,i)=dYY_Ci(k)
6479          dYY_C1tab(k,i)=dYY_Ci1(k)
6480          dZZ_Ctab(k,i)=dZZ_Ci(k)
6481          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6482          dXX_XYZtab(k,i)=dXX_XYZ(k)
6483          dYY_XYZtab(k,i)=dYY_XYZ(k)
6484          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6485        enddo
6486
6487        do k = 1,3
6488 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6489 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6490 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6491 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6492 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6493 !     &    dt_dci(k)
6494 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6495 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6496          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6497           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6498          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6499           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6500          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6501           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6502        enddo
6503 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6504 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6505
6506 ! to check gradient call subroutine check_grad
6507
6508     1 continue
6509       enddo
6510       return
6511       end subroutine esc
6512 !-----------------------------------------------------------------------------
6513       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6514 !      implicit none
6515       real(kind=8),dimension(65) :: x
6516       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6517         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6518
6519       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6520         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6521         + x(10)*yy*zz
6522       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6523         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6524         + x(20)*yy*zz
6525       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6526         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6527         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6528         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6529         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6530         +x(40)*xx*yy*zz
6531       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6532         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6533         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6534         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6535         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6536         +x(60)*xx*yy*zz
6537       dsc_i   = 0.743d0+x(61)
6538       dp2_i   = 1.9d0+x(62)
6539       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6540                 *(xx*cost2+yy*sint2))
6541       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6542                 *(xx*cost2-yy*sint2))
6543       s1=(1+x(63))/(0.1d0 + dscp1)
6544       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6545       s2=(1+x(65))/(0.1d0 + dscp2)
6546       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6547       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6548        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6549       enesc=sumene
6550       return
6551       end function enesc
6552 #endif
6553 !-----------------------------------------------------------------------------
6554       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6555 !
6556 ! This procedure calculates two-body contact function g(rij) and its derivative:
6557 !
6558 !           eps0ij                                     !       x < -1
6559 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6560 !            0                                         !       x > 1
6561 !
6562 ! where x=(rij-r0ij)/delta
6563 !
6564 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6565 !
6566 !      implicit none
6567       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6568       real(kind=8) :: x,x2,x4,delta
6569 !     delta=0.02D0*r0ij
6570 !      delta=0.2D0*r0ij
6571       x=(rij-r0ij)/delta
6572       if (x.lt.-1.0D0) then
6573         fcont=eps0ij
6574         fprimcont=0.0D0
6575       else if (x.le.1.0D0) then
6576         x2=x*x
6577         x4=x2*x2
6578         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6579         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6580       else
6581         fcont=0.0D0
6582         fprimcont=0.0D0
6583       endif
6584       return
6585       end subroutine gcont
6586 !-----------------------------------------------------------------------------
6587       subroutine splinthet(theti,delta,ss,ssder)
6588 !      implicit real*8 (a-h,o-z)
6589 !      include 'DIMENSIONS'
6590 !      include 'COMMON.VAR'
6591 !      include 'COMMON.GEO'
6592       real(kind=8) :: theti,delta,ss,ssder
6593       real(kind=8) :: thetup,thetlow
6594       thetup=pi-delta
6595       thetlow=delta
6596       if (theti.gt.pipol) then
6597         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6598       else
6599         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6600         ssder=-ssder
6601       endif
6602       return
6603       end subroutine splinthet
6604 !-----------------------------------------------------------------------------
6605       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6606 !      implicit none
6607       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6608       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6609       a1=fprim0*delta/(f1-f0)
6610       a2=3.0d0-2.0d0*a1
6611       a3=a1-2.0d0
6612       ksi=(x-x0)/delta
6613       ksi2=ksi*ksi
6614       ksi3=ksi2*ksi
6615       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6616       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6617       return
6618       end subroutine spline1
6619 !-----------------------------------------------------------------------------
6620       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6621 !      implicit none
6622       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6623       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6624       ksi=(x-x0)/delta
6625       ksi2=ksi*ksi
6626       ksi3=ksi2*ksi
6627       a1=fprim0x*delta
6628       a2=3*(f1x-f0x)-2*fprim0x*delta
6629       a3=fprim0x*delta-2*(f1x-f0x)
6630       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6631       return
6632       end subroutine spline2
6633 !-----------------------------------------------------------------------------
6634 #ifdef CRYST_TOR
6635 !-----------------------------------------------------------------------------
6636       subroutine etor(etors,edihcnstr)
6637 !      implicit real*8 (a-h,o-z)
6638 !      include 'DIMENSIONS'
6639 !      include 'COMMON.VAR'
6640 !      include 'COMMON.GEO'
6641 !      include 'COMMON.LOCAL'
6642 !      include 'COMMON.TORSION'
6643 !      include 'COMMON.INTERACT'
6644 !      include 'COMMON.DERIV'
6645 !      include 'COMMON.CHAIN'
6646 !      include 'COMMON.NAMES'
6647 !      include 'COMMON.IOUNITS'
6648 !      include 'COMMON.FFIELD'
6649 !      include 'COMMON.TORCNSTR'
6650 !      include 'COMMON.CONTROL'
6651       real(kind=8) :: etors,edihcnstr
6652       logical :: lprn
6653 !el local variables
6654       integer :: i,j,
6655       real(kind=8) :: phii,fac,etors_ii
6656
6657 ! Set lprn=.true. for debugging
6658       lprn=.false.
6659 !      lprn=.true.
6660       etors=0.0D0
6661       do i=iphi_start,iphi_end
6662       etors_ii=0.0D0
6663         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6664             .or. itype(i,1).eq.ntyp1) cycle
6665         itori=itortyp(itype(i-2,1))
6666         itori1=itortyp(itype(i-1,1))
6667         phii=phi(i)
6668         gloci=0.0D0
6669 ! Proline-Proline pair is a special case...
6670         if (itori.eq.3 .and. itori1.eq.3) then
6671           if (phii.gt.-dwapi3) then
6672             cosphi=dcos(3*phii)
6673             fac=1.0D0/(1.0D0-cosphi)
6674             etorsi=v1(1,3,3)*fac
6675             etorsi=etorsi+etorsi
6676             etors=etors+etorsi-v1(1,3,3)
6677             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6678             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6679           endif
6680           do j=1,3
6681             v1ij=v1(j+1,itori,itori1)
6682             v2ij=v2(j+1,itori,itori1)
6683             cosphi=dcos(j*phii)
6684             sinphi=dsin(j*phii)
6685             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6686             if (energy_dec) etors_ii=etors_ii+ &
6687                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6688             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6689           enddo
6690         else
6691           do j=1,nterm_old
6692             v1ij=v1(j,itori,itori1)
6693             v2ij=v2(j,itori,itori1)
6694             cosphi=dcos(j*phii)
6695             sinphi=dsin(j*phii)
6696             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6697             if (energy_dec) etors_ii=etors_ii+ &
6698                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6699             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6700           enddo
6701         endif
6702         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6703              'etor',i,etors_ii
6704         if (lprn) &
6705         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6706         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6707         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6708         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6709 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6710       enddo
6711 ! 6/20/98 - dihedral angle constraints
6712       edihcnstr=0.0d0
6713       do i=1,ndih_constr
6714         itori=idih_constr(i)
6715         phii=phi(itori)
6716         difi=phii-phi0(i)
6717         if (difi.gt.drange(i)) then
6718           difi=difi-drange(i)
6719           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6720           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6721         else if (difi.lt.-drange(i)) then
6722           difi=difi+drange(i)
6723           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6724           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6725         endif
6726 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6727 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6728       enddo
6729 !      write (iout,*) 'edihcnstr',edihcnstr
6730       return
6731       end subroutine etor
6732 !-----------------------------------------------------------------------------
6733       subroutine etor_d(etors_d)
6734       real(kind=8) :: etors_d
6735       etors_d=0.0d0
6736       return
6737       end subroutine etor_d
6738 #else
6739 !-----------------------------------------------------------------------------
6740       subroutine etor(etors,edihcnstr)
6741 !      implicit real*8 (a-h,o-z)
6742 !      include 'DIMENSIONS'
6743 !      include 'COMMON.VAR'
6744 !      include 'COMMON.GEO'
6745 !      include 'COMMON.LOCAL'
6746 !      include 'COMMON.TORSION'
6747 !      include 'COMMON.INTERACT'
6748 !      include 'COMMON.DERIV'
6749 !      include 'COMMON.CHAIN'
6750 !      include 'COMMON.NAMES'
6751 !      include 'COMMON.IOUNITS'
6752 !      include 'COMMON.FFIELD'
6753 !      include 'COMMON.TORCNSTR'
6754 !      include 'COMMON.CONTROL'
6755       real(kind=8) :: etors,edihcnstr
6756       logical :: lprn
6757 !el local variables
6758       integer :: i,j,iblock,itori,itori1
6759       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6760                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6761 ! Set lprn=.true. for debugging
6762       lprn=.false.
6763 !     lprn=.true.
6764       etors=0.0D0
6765       do i=iphi_start,iphi_end
6766         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6767              .or. itype(i-3,1).eq.ntyp1 &
6768              .or. itype(i,1).eq.ntyp1) cycle
6769         etors_ii=0.0D0
6770          if (iabs(itype(i,1)).eq.20) then
6771          iblock=2
6772          else
6773          iblock=1
6774          endif
6775         itori=itortyp(itype(i-2,1))
6776         itori1=itortyp(itype(i-1,1))
6777         phii=phi(i)
6778         gloci=0.0D0
6779 ! Regular cosine and sine terms
6780         do j=1,nterm(itori,itori1,iblock)
6781           v1ij=v1(j,itori,itori1,iblock)
6782           v2ij=v2(j,itori,itori1,iblock)
6783           cosphi=dcos(j*phii)
6784           sinphi=dsin(j*phii)
6785           etors=etors+v1ij*cosphi+v2ij*sinphi
6786           if (energy_dec) etors_ii=etors_ii+ &
6787                      v1ij*cosphi+v2ij*sinphi
6788           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6789         enddo
6790 ! Lorentz terms
6791 !                         v1
6792 !  E = SUM ----------------------------------- - v1
6793 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6794 !
6795         cosphi=dcos(0.5d0*phii)
6796         sinphi=dsin(0.5d0*phii)
6797         do j=1,nlor(itori,itori1,iblock)
6798           vl1ij=vlor1(j,itori,itori1)
6799           vl2ij=vlor2(j,itori,itori1)
6800           vl3ij=vlor3(j,itori,itori1)
6801           pom=vl2ij*cosphi+vl3ij*sinphi
6802           pom1=1.0d0/(pom*pom+1.0d0)
6803           etors=etors+vl1ij*pom1
6804           if (energy_dec) etors_ii=etors_ii+ &
6805                      vl1ij*pom1
6806           pom=-pom*pom1*pom1
6807           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6808         enddo
6809 ! Subtract the constant term
6810         etors=etors-v0(itori,itori1,iblock)
6811           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6812                'etor',i,etors_ii-v0(itori,itori1,iblock)
6813         if (lprn) &
6814         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6815         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6816         (v1(j,itori,itori1,iblock),j=1,6),&
6817         (v2(j,itori,itori1,iblock),j=1,6)
6818         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6819 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6820       enddo
6821 ! 6/20/98 - dihedral angle constraints
6822       edihcnstr=0.0d0
6823 !      do i=1,ndih_constr
6824       do i=idihconstr_start,idihconstr_end
6825         itori=idih_constr(i)
6826         phii=phi(itori)
6827         difi=pinorm(phii-phi0(i))
6828         if (difi.gt.drange(i)) then
6829           difi=difi-drange(i)
6830           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6831           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6832         else if (difi.lt.-drange(i)) then
6833           difi=difi+drange(i)
6834           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6835           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6836         else
6837           difi=0.0
6838         endif
6839 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6840 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6841 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6842       enddo
6843 !d       write (iout,*) 'edihcnstr',edihcnstr
6844       return
6845       end subroutine etor
6846 !-----------------------------------------------------------------------------
6847       subroutine etor_d(etors_d)
6848 ! 6/23/01 Compute double torsional energy
6849 !      implicit real*8 (a-h,o-z)
6850 !      include 'DIMENSIONS'
6851 !      include 'COMMON.VAR'
6852 !      include 'COMMON.GEO'
6853 !      include 'COMMON.LOCAL'
6854 !      include 'COMMON.TORSION'
6855 !      include 'COMMON.INTERACT'
6856 !      include 'COMMON.DERIV'
6857 !      include 'COMMON.CHAIN'
6858 !      include 'COMMON.NAMES'
6859 !      include 'COMMON.IOUNITS'
6860 !      include 'COMMON.FFIELD'
6861 !      include 'COMMON.TORCNSTR'
6862       real(kind=8) :: etors_d,etors_d_ii
6863       logical :: lprn
6864 !el local variables
6865       integer :: i,j,k,l,itori,itori1,itori2,iblock
6866       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6867                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6868                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6869                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6870 ! Set lprn=.true. for debugging
6871       lprn=.false.
6872 !     lprn=.true.
6873       etors_d=0.0D0
6874 !      write(iout,*) "a tu??"
6875       do i=iphid_start,iphid_end
6876         etors_d_ii=0.0D0
6877         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6878             .or. itype(i-3,1).eq.ntyp1 &
6879             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6880         itori=itortyp(itype(i-2,1))
6881         itori1=itortyp(itype(i-1,1))
6882         itori2=itortyp(itype(i,1))
6883         phii=phi(i)
6884         phii1=phi(i+1)
6885         gloci1=0.0D0
6886         gloci2=0.0D0
6887         iblock=1
6888         if (iabs(itype(i+1,1)).eq.20) iblock=2
6889
6890 ! Regular cosine and sine terms
6891         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6892           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6893           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6894           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6895           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6896           cosphi1=dcos(j*phii)
6897           sinphi1=dsin(j*phii)
6898           cosphi2=dcos(j*phii1)
6899           sinphi2=dsin(j*phii1)
6900           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6901            v2cij*cosphi2+v2sij*sinphi2
6902           if (energy_dec) etors_d_ii=etors_d_ii+ &
6903            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6904           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6905           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6906         enddo
6907         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6908           do l=1,k-1
6909             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6910             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6911             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6912             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6913             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6914             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6915             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6916             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6917             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6918               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6919             if (energy_dec) etors_d_ii=etors_d_ii+ &
6920               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6921               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6922             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6923               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6924             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6925               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6926           enddo
6927         enddo
6928         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6929                             'etor_d',i,etors_d_ii
6930         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6931         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6932       enddo
6933       return
6934       end subroutine etor_d
6935 #endif
6936 !-----------------------------------------------------------------------------
6937       subroutine eback_sc_corr(esccor)
6938 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
6939 !        conformational states; temporarily implemented as differences
6940 !        between UNRES torsional potentials (dependent on three types of
6941 !        residues) and the torsional potentials dependent on all 20 types
6942 !        of residues computed from AM1  energy surfaces of terminally-blocked
6943 !        amino-acid residues.
6944 !      implicit real*8 (a-h,o-z)
6945 !      include 'DIMENSIONS'
6946 !      include 'COMMON.VAR'
6947 !      include 'COMMON.GEO'
6948 !      include 'COMMON.LOCAL'
6949 !      include 'COMMON.TORSION'
6950 !      include 'COMMON.SCCOR'
6951 !      include 'COMMON.INTERACT'
6952 !      include 'COMMON.DERIV'
6953 !      include 'COMMON.CHAIN'
6954 !      include 'COMMON.NAMES'
6955 !      include 'COMMON.IOUNITS'
6956 !      include 'COMMON.FFIELD'
6957 !      include 'COMMON.CONTROL'
6958       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
6959                    cosphi,sinphi
6960       logical :: lprn
6961       integer :: i,interty,j,isccori,isccori1,intertyp
6962 ! Set lprn=.true. for debugging
6963       lprn=.false.
6964 !      lprn=.true.
6965 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6966       esccor=0.0D0
6967       do i=itau_start,itau_end
6968         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
6969         esccor_ii=0.0D0
6970         isccori=isccortyp(itype(i-2,1))
6971         isccori1=isccortyp(itype(i-1,1))
6972
6973 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6974         phii=phi(i)
6975         do intertyp=1,3 !intertyp
6976          esccor_ii=0.0D0
6977 !c Added 09 May 2012 (Adasko)
6978 !c  Intertyp means interaction type of backbone mainchain correlation:
6979 !   1 = SC...Ca...Ca...Ca
6980 !   2 = Ca...Ca...Ca...SC
6981 !   3 = SC...Ca...Ca...SCi
6982         gloci=0.0D0
6983         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
6984             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
6985             (itype(i-1,1).eq.ntyp1))) &
6986           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
6987            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
6988            .or.(itype(i,1).eq.ntyp1))) &
6989           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
6990             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
6991             (itype(i-3,1).eq.ntyp1)))) cycle
6992         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
6993         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
6994        cycle
6995        do j=1,nterm_sccor(isccori,isccori1)
6996           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6997           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6998           cosphi=dcos(j*tauangle(intertyp,i))
6999           sinphi=dsin(j*tauangle(intertyp,i))
7000           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7001           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7002           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7003         enddo
7004         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7005                                 'esccor',i,intertyp,esccor_ii
7006 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7007         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7008         if (lprn) &
7009         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7010         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7011         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7012         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7013         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7014        enddo !intertyp
7015       enddo
7016
7017       return
7018       end subroutine eback_sc_corr
7019 !-----------------------------------------------------------------------------
7020       subroutine multibody(ecorr)
7021 ! This subroutine calculates multi-body contributions to energy following
7022 ! the idea of Skolnick et al. If side chains I and J make a contact and
7023 ! at the same time side chains I+1 and J+1 make a contact, an extra
7024 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7025 !      implicit real*8 (a-h,o-z)
7026 !      include 'DIMENSIONS'
7027 !      include 'COMMON.IOUNITS'
7028 !      include 'COMMON.DERIV'
7029 !      include 'COMMON.INTERACT'
7030 !      include 'COMMON.CONTACTS'
7031       real(kind=8),dimension(3) :: gx,gx1
7032       logical :: lprn
7033       real(kind=8) :: ecorr
7034       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7035 ! Set lprn=.true. for debugging
7036       lprn=.false.
7037
7038       if (lprn) then
7039         write (iout,'(a)') 'Contact function values:'
7040         do i=nnt,nct-2
7041           write (iout,'(i2,20(1x,i2,f10.5))') &
7042               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7043         enddo
7044       endif
7045       ecorr=0.0D0
7046
7047 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7048 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7049       do i=nnt,nct
7050         do j=1,3
7051           gradcorr(j,i)=0.0D0
7052           gradxorr(j,i)=0.0D0
7053         enddo
7054       enddo
7055       do i=nnt,nct-2
7056
7057         DO ISHIFT = 3,4
7058
7059         i1=i+ishift
7060         num_conti=num_cont(i)
7061         num_conti1=num_cont(i1)
7062         do jj=1,num_conti
7063           j=jcont(jj,i)
7064           do kk=1,num_conti1
7065             j1=jcont(kk,i1)
7066             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7067 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7068 !d   &                   ' ishift=',ishift
7069 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7070 ! The system gains extra energy.
7071               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7072             endif   ! j1==j+-ishift
7073           enddo     ! kk
7074         enddo       ! jj
7075
7076         ENDDO ! ISHIFT
7077
7078       enddo         ! i
7079       return
7080       end subroutine multibody
7081 !-----------------------------------------------------------------------------
7082       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7083 !      implicit real*8 (a-h,o-z)
7084 !      include 'DIMENSIONS'
7085 !      include 'COMMON.IOUNITS'
7086 !      include 'COMMON.DERIV'
7087 !      include 'COMMON.INTERACT'
7088 !      include 'COMMON.CONTACTS'
7089       real(kind=8),dimension(3) :: gx,gx1
7090       logical :: lprn
7091       integer :: i,j,k,l,jj,kk,m,ll
7092       real(kind=8) :: eij,ekl
7093       lprn=.false.
7094       eij=facont(jj,i)
7095       ekl=facont(kk,k)
7096 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7097 ! Calculate the multi-body contribution to energy.
7098 ! Calculate multi-body contributions to the gradient.
7099 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7100 !d   & k,l,(gacont(m,kk,k),m=1,3)
7101       do m=1,3
7102         gx(m) =ekl*gacont(m,jj,i)
7103         gx1(m)=eij*gacont(m,kk,k)
7104         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7105         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7106         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7107         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7108       enddo
7109       do m=i,j-1
7110         do ll=1,3
7111           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7112         enddo
7113       enddo
7114       do m=k,l-1
7115         do ll=1,3
7116           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7117         enddo
7118       enddo
7119       esccorr=-eij*ekl
7120       return
7121       end function esccorr
7122 !-----------------------------------------------------------------------------
7123       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7124 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7125 !      implicit real*8 (a-h,o-z)
7126 !      include 'DIMENSIONS'
7127 !      include 'COMMON.IOUNITS'
7128 #ifdef MPI
7129       include "mpif.h"
7130 !      integer :: maxconts !max_cont=maxconts  =nres/4
7131       integer,parameter :: max_dim=26
7132       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7133       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7134 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7135 !el      common /przechowalnia/ zapas
7136       integer :: status(MPI_STATUS_SIZE)
7137       integer,dimension((nres/4)*2) :: req !maxconts*2
7138       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7139 #endif
7140 !      include 'COMMON.SETUP'
7141 !      include 'COMMON.FFIELD'
7142 !      include 'COMMON.DERIV'
7143 !      include 'COMMON.INTERACT'
7144 !      include 'COMMON.CONTACTS'
7145 !      include 'COMMON.CONTROL'
7146 !      include 'COMMON.LOCAL'
7147       real(kind=8),dimension(3) :: gx,gx1
7148       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7149       logical :: lprn,ldone
7150 !el local variables
7151       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7152               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7153
7154 ! Set lprn=.true. for debugging
7155       lprn=.false.
7156 #ifdef MPI
7157 !      maxconts=nres/4
7158       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7159       n_corr=0
7160       n_corr1=0
7161       if (nfgtasks.le.1) goto 30
7162       if (lprn) then
7163         write (iout,'(a)') 'Contact function values before RECEIVE:'
7164         do i=nnt,nct-2
7165           write (iout,'(2i3,50(1x,i2,f5.2))') &
7166           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7167           j=1,num_cont_hb(i))
7168         enddo
7169       endif
7170       call flush(iout)
7171       do i=1,ntask_cont_from
7172         ncont_recv(i)=0
7173       enddo
7174       do i=1,ntask_cont_to
7175         ncont_sent(i)=0
7176       enddo
7177 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7178 !     & ntask_cont_to
7179 ! Make the list of contacts to send to send to other procesors
7180 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7181 !      call flush(iout)
7182       do i=iturn3_start,iturn3_end
7183 !        write (iout,*) "make contact list turn3",i," num_cont",
7184 !     &    num_cont_hb(i)
7185         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7186       enddo
7187       do i=iturn4_start,iturn4_end
7188 !        write (iout,*) "make contact list turn4",i," num_cont",
7189 !     &   num_cont_hb(i)
7190         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7191       enddo
7192       do ii=1,nat_sent
7193         i=iat_sent(ii)
7194 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7195 !     &    num_cont_hb(i)
7196         do j=1,num_cont_hb(i)
7197         do k=1,4
7198           jjc=jcont_hb(j,i)
7199           iproc=iint_sent_local(k,jjc,ii)
7200 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7201           if (iproc.gt.0) then
7202             ncont_sent(iproc)=ncont_sent(iproc)+1
7203             nn=ncont_sent(iproc)
7204             zapas(1,nn,iproc)=i
7205             zapas(2,nn,iproc)=jjc
7206             zapas(3,nn,iproc)=facont_hb(j,i)
7207             zapas(4,nn,iproc)=ees0p(j,i)
7208             zapas(5,nn,iproc)=ees0m(j,i)
7209             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7210             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7211             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7212             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7213             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7214             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7215             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7216             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7217             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7218             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7219             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7220             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7221             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7222             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7223             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7224             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7225             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7226             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7227             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7228             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7229             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7230           endif
7231         enddo
7232         enddo
7233       enddo
7234       if (lprn) then
7235       write (iout,*) &
7236         "Numbers of contacts to be sent to other processors",&
7237         (ncont_sent(i),i=1,ntask_cont_to)
7238       write (iout,*) "Contacts sent"
7239       do ii=1,ntask_cont_to
7240         nn=ncont_sent(ii)
7241         iproc=itask_cont_to(ii)
7242         write (iout,*) nn," contacts to processor",iproc,&
7243          " of CONT_TO_COMM group"
7244         do i=1,nn
7245           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7246         enddo
7247       enddo
7248       call flush(iout)
7249       endif
7250       CorrelType=477
7251       CorrelID=fg_rank+1
7252       CorrelType1=478
7253       CorrelID1=nfgtasks+fg_rank+1
7254       ireq=0
7255 ! Receive the numbers of needed contacts from other processors
7256       do ii=1,ntask_cont_from
7257         iproc=itask_cont_from(ii)
7258         ireq=ireq+1
7259         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7260           FG_COMM,req(ireq),IERR)
7261       enddo
7262 !      write (iout,*) "IRECV ended"
7263 !      call flush(iout)
7264 ! Send the number of contacts needed by other processors
7265       do ii=1,ntask_cont_to
7266         iproc=itask_cont_to(ii)
7267         ireq=ireq+1
7268         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7269           FG_COMM,req(ireq),IERR)
7270       enddo
7271 !      write (iout,*) "ISEND ended"
7272 !      write (iout,*) "number of requests (nn)",ireq
7273       call flush(iout)
7274       if (ireq.gt.0) &
7275         call MPI_Waitall(ireq,req,status_array,ierr)
7276 !      write (iout,*)
7277 !     &  "Numbers of contacts to be received from other processors",
7278 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7279 !      call flush(iout)
7280 ! Receive contacts
7281       ireq=0
7282       do ii=1,ntask_cont_from
7283         iproc=itask_cont_from(ii)
7284         nn=ncont_recv(ii)
7285 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7286 !     &   " of CONT_TO_COMM group"
7287         call flush(iout)
7288         if (nn.gt.0) then
7289           ireq=ireq+1
7290           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7291           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7292 !          write (iout,*) "ireq,req",ireq,req(ireq)
7293         endif
7294       enddo
7295 ! Send the contacts to processors that need them
7296       do ii=1,ntask_cont_to
7297         iproc=itask_cont_to(ii)
7298         nn=ncont_sent(ii)
7299 !        write (iout,*) nn," contacts to processor",iproc,
7300 !     &   " of CONT_TO_COMM group"
7301         if (nn.gt.0) then
7302           ireq=ireq+1
7303           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7304             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7305 !          write (iout,*) "ireq,req",ireq,req(ireq)
7306 !          do i=1,nn
7307 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7308 !          enddo
7309         endif
7310       enddo
7311 !      write (iout,*) "number of requests (contacts)",ireq
7312 !      write (iout,*) "req",(req(i),i=1,4)
7313 !      call flush(iout)
7314       if (ireq.gt.0) &
7315        call MPI_Waitall(ireq,req,status_array,ierr)
7316       do iii=1,ntask_cont_from
7317         iproc=itask_cont_from(iii)
7318         nn=ncont_recv(iii)
7319         if (lprn) then
7320         write (iout,*) "Received",nn," contacts from processor",iproc,&
7321          " of CONT_FROM_COMM group"
7322         call flush(iout)
7323         do i=1,nn
7324           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7325         enddo
7326         call flush(iout)
7327         endif
7328         do i=1,nn
7329           ii=zapas_recv(1,i,iii)
7330 ! Flag the received contacts to prevent double-counting
7331           jj=-zapas_recv(2,i,iii)
7332 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7333 !          call flush(iout)
7334           nnn=num_cont_hb(ii)+1
7335           num_cont_hb(ii)=nnn
7336           jcont_hb(nnn,ii)=jj
7337           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7338           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7339           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7340           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7341           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7342           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7343           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7344           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7345           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7346           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7347           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7348           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7349           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7350           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7351           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7352           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7353           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7354           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7355           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7356           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7357           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7358           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7359           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7360           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7361         enddo
7362       enddo
7363       call flush(iout)
7364       if (lprn) then
7365         write (iout,'(a)') 'Contact function values after receive:'
7366         do i=nnt,nct-2
7367           write (iout,'(2i3,50(1x,i3,f5.2))') &
7368           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7369           j=1,num_cont_hb(i))
7370         enddo
7371         call flush(iout)
7372       endif
7373    30 continue
7374 #endif
7375       if (lprn) then
7376         write (iout,'(a)') 'Contact function values:'
7377         do i=nnt,nct-2
7378           write (iout,'(2i3,50(1x,i3,f5.2))') &
7379           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7380           j=1,num_cont_hb(i))
7381         enddo
7382       endif
7383       ecorr=0.0D0
7384
7385 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7386 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7387 ! Remove the loop below after debugging !!!
7388       do i=nnt,nct
7389         do j=1,3
7390           gradcorr(j,i)=0.0D0
7391           gradxorr(j,i)=0.0D0
7392         enddo
7393       enddo
7394 ! Calculate the local-electrostatic correlation terms
7395       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7396         i1=i+1
7397         num_conti=num_cont_hb(i)
7398         num_conti1=num_cont_hb(i+1)
7399         do jj=1,num_conti
7400           j=jcont_hb(jj,i)
7401           jp=iabs(j)
7402           do kk=1,num_conti1
7403             j1=jcont_hb(kk,i1)
7404             jp1=iabs(j1)
7405 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7406 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7407             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7408                 .or. j.lt.0 .and. j1.gt.0) .and. &
7409                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7410 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7411 ! The system gains extra energy.
7412               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7413               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7414                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7415               n_corr=n_corr+1
7416             else if (j1.eq.j) then
7417 ! Contacts I-J and I-(J+1) occur simultaneously.
7418 ! The system loses extra energy.
7419 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7420             endif
7421           enddo ! kk
7422           do kk=1,num_conti
7423             j1=jcont_hb(kk,i)
7424 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7425 !    &         ' jj=',jj,' kk=',kk
7426             if (j1.eq.j+1) then
7427 ! Contacts I-J and (I+1)-J occur simultaneously.
7428 ! The system loses extra energy.
7429 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7430             endif ! j1==j+1
7431           enddo ! kk
7432         enddo ! jj
7433       enddo ! i
7434       return
7435       end subroutine multibody_hb
7436 !-----------------------------------------------------------------------------
7437       subroutine add_hb_contact(ii,jj,itask)
7438 !      implicit real*8 (a-h,o-z)
7439 !      include "DIMENSIONS"
7440 !      include "COMMON.IOUNITS"
7441 !      include "COMMON.CONTACTS"
7442 !      integer,parameter :: maxconts=nres/4
7443       integer,parameter :: max_dim=26
7444       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7445 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7446 !      common /przechowalnia/ zapas
7447       integer :: i,j,ii,jj,iproc,nn,jjc
7448       integer,dimension(4) :: itask
7449 !      write (iout,*) "itask",itask
7450       do i=1,2
7451         iproc=itask(i)
7452         if (iproc.gt.0) then
7453           do j=1,num_cont_hb(ii)
7454             jjc=jcont_hb(j,ii)
7455 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7456             if (jjc.eq.jj) then
7457               ncont_sent(iproc)=ncont_sent(iproc)+1
7458               nn=ncont_sent(iproc)
7459               zapas(1,nn,iproc)=ii
7460               zapas(2,nn,iproc)=jjc
7461               zapas(3,nn,iproc)=facont_hb(j,ii)
7462               zapas(4,nn,iproc)=ees0p(j,ii)
7463               zapas(5,nn,iproc)=ees0m(j,ii)
7464               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7465               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7466               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7467               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7468               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7469               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7470               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7471               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7472               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7473               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7474               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7475               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7476               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7477               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7478               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7479               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7480               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7481               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7482               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7483               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7484               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7485               exit
7486             endif
7487           enddo
7488         endif
7489       enddo
7490       return
7491       end subroutine add_hb_contact
7492 !-----------------------------------------------------------------------------
7493       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7494 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7495 !      implicit real*8 (a-h,o-z)
7496 !      include 'DIMENSIONS'
7497 !      include 'COMMON.IOUNITS'
7498       integer,parameter :: max_dim=70
7499 #ifdef MPI
7500       include "mpif.h"
7501 !      integer :: maxconts !max_cont=maxconts=nres/4
7502       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7503       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7504 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7505 !      common /przechowalnia/ zapas
7506       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7507         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7508         ierr,iii,nnn
7509 #endif
7510 !      include 'COMMON.SETUP'
7511 !      include 'COMMON.FFIELD'
7512 !      include 'COMMON.DERIV'
7513 !      include 'COMMON.LOCAL'
7514 !      include 'COMMON.INTERACT'
7515 !      include 'COMMON.CONTACTS'
7516 !      include 'COMMON.CHAIN'
7517 !      include 'COMMON.CONTROL'
7518       real(kind=8),dimension(3) :: gx,gx1
7519       integer,dimension(nres) :: num_cont_hb_old
7520       logical :: lprn,ldone
7521 !EL      double precision eello4,eello5,eelo6,eello_turn6
7522 !EL      external eello4,eello5,eello6,eello_turn6
7523 !el local variables
7524       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7525               j1,jp1,i1,num_conti1
7526       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7527       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7528
7529 ! Set lprn=.true. for debugging
7530       lprn=.false.
7531       eturn6=0.0d0
7532 #ifdef MPI
7533 !      maxconts=nres/4
7534       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7535       do i=1,nres
7536         num_cont_hb_old(i)=num_cont_hb(i)
7537       enddo
7538       n_corr=0
7539       n_corr1=0
7540       if (nfgtasks.le.1) goto 30
7541       if (lprn) then
7542         write (iout,'(a)') 'Contact function values before RECEIVE:'
7543         do i=nnt,nct-2
7544           write (iout,'(2i3,50(1x,i2,f5.2))') &
7545           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7546           j=1,num_cont_hb(i))
7547         enddo
7548       endif
7549       call flush(iout)
7550       do i=1,ntask_cont_from
7551         ncont_recv(i)=0
7552       enddo
7553       do i=1,ntask_cont_to
7554         ncont_sent(i)=0
7555       enddo
7556 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7557 !     & ntask_cont_to
7558 ! Make the list of contacts to send to send to other procesors
7559       do i=iturn3_start,iturn3_end
7560 !        write (iout,*) "make contact list turn3",i," num_cont",
7561 !     &    num_cont_hb(i)
7562         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7563       enddo
7564       do i=iturn4_start,iturn4_end
7565 !        write (iout,*) "make contact list turn4",i," num_cont",
7566 !     &   num_cont_hb(i)
7567         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7568       enddo
7569       do ii=1,nat_sent
7570         i=iat_sent(ii)
7571 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7572 !     &    num_cont_hb(i)
7573         do j=1,num_cont_hb(i)
7574         do k=1,4
7575           jjc=jcont_hb(j,i)
7576           iproc=iint_sent_local(k,jjc,ii)
7577 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7578           if (iproc.ne.0) then
7579             ncont_sent(iproc)=ncont_sent(iproc)+1
7580             nn=ncont_sent(iproc)
7581             zapas(1,nn,iproc)=i
7582             zapas(2,nn,iproc)=jjc
7583             zapas(3,nn,iproc)=d_cont(j,i)
7584             ind=3
7585             do kk=1,3
7586               ind=ind+1
7587               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7588             enddo
7589             do kk=1,2
7590               do ll=1,2
7591                 ind=ind+1
7592                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7593               enddo
7594             enddo
7595             do jj=1,5
7596               do kk=1,3
7597                 do ll=1,2
7598                   do mm=1,2
7599                     ind=ind+1
7600                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7601                   enddo
7602                 enddo
7603               enddo
7604             enddo
7605           endif
7606         enddo
7607         enddo
7608       enddo
7609       if (lprn) then
7610       write (iout,*) &
7611         "Numbers of contacts to be sent to other processors",&
7612         (ncont_sent(i),i=1,ntask_cont_to)
7613       write (iout,*) "Contacts sent"
7614       do ii=1,ntask_cont_to
7615         nn=ncont_sent(ii)
7616         iproc=itask_cont_to(ii)
7617         write (iout,*) nn," contacts to processor",iproc,&
7618          " of CONT_TO_COMM group"
7619         do i=1,nn
7620           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7621         enddo
7622       enddo
7623       call flush(iout)
7624       endif
7625       CorrelType=477
7626       CorrelID=fg_rank+1
7627       CorrelType1=478
7628       CorrelID1=nfgtasks+fg_rank+1
7629       ireq=0
7630 ! Receive the numbers of needed contacts from other processors
7631       do ii=1,ntask_cont_from
7632         iproc=itask_cont_from(ii)
7633         ireq=ireq+1
7634         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7635           FG_COMM,req(ireq),IERR)
7636       enddo
7637 !      write (iout,*) "IRECV ended"
7638 !      call flush(iout)
7639 ! Send the number of contacts needed by other processors
7640       do ii=1,ntask_cont_to
7641         iproc=itask_cont_to(ii)
7642         ireq=ireq+1
7643         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7644           FG_COMM,req(ireq),IERR)
7645       enddo
7646 !      write (iout,*) "ISEND ended"
7647 !      write (iout,*) "number of requests (nn)",ireq
7648       call flush(iout)
7649       if (ireq.gt.0) &
7650         call MPI_Waitall(ireq,req,status_array,ierr)
7651 !      write (iout,*)
7652 !     &  "Numbers of contacts to be received from other processors",
7653 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7654 !      call flush(iout)
7655 ! Receive contacts
7656       ireq=0
7657       do ii=1,ntask_cont_from
7658         iproc=itask_cont_from(ii)
7659         nn=ncont_recv(ii)
7660 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7661 !     &   " of CONT_TO_COMM group"
7662         call flush(iout)
7663         if (nn.gt.0) then
7664           ireq=ireq+1
7665           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7666           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7667 !          write (iout,*) "ireq,req",ireq,req(ireq)
7668         endif
7669       enddo
7670 ! Send the contacts to processors that need them
7671       do ii=1,ntask_cont_to
7672         iproc=itask_cont_to(ii)
7673         nn=ncont_sent(ii)
7674 !        write (iout,*) nn," contacts to processor",iproc,
7675 !     &   " of CONT_TO_COMM group"
7676         if (nn.gt.0) then
7677           ireq=ireq+1
7678           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7679             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7680 !          write (iout,*) "ireq,req",ireq,req(ireq)
7681 !          do i=1,nn
7682 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7683 !          enddo
7684         endif
7685       enddo
7686 !      write (iout,*) "number of requests (contacts)",ireq
7687 !      write (iout,*) "req",(req(i),i=1,4)
7688 !      call flush(iout)
7689       if (ireq.gt.0) &
7690        call MPI_Waitall(ireq,req,status_array,ierr)
7691       do iii=1,ntask_cont_from
7692         iproc=itask_cont_from(iii)
7693         nn=ncont_recv(iii)
7694         if (lprn) then
7695         write (iout,*) "Received",nn," contacts from processor",iproc,&
7696          " of CONT_FROM_COMM group"
7697         call flush(iout)
7698         do i=1,nn
7699           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7700         enddo
7701         call flush(iout)
7702         endif
7703         do i=1,nn
7704           ii=zapas_recv(1,i,iii)
7705 ! Flag the received contacts to prevent double-counting
7706           jj=-zapas_recv(2,i,iii)
7707 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7708 !          call flush(iout)
7709           nnn=num_cont_hb(ii)+1
7710           num_cont_hb(ii)=nnn
7711           jcont_hb(nnn,ii)=jj
7712           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7713           ind=3
7714           do kk=1,3
7715             ind=ind+1
7716             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7717           enddo
7718           do kk=1,2
7719             do ll=1,2
7720               ind=ind+1
7721               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7722             enddo
7723           enddo
7724           do jj=1,5
7725             do kk=1,3
7726               do ll=1,2
7727                 do mm=1,2
7728                   ind=ind+1
7729                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7730                 enddo
7731               enddo
7732             enddo
7733           enddo
7734         enddo
7735       enddo
7736       call flush(iout)
7737       if (lprn) then
7738         write (iout,'(a)') 'Contact function values after receive:'
7739         do i=nnt,nct-2
7740           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7741           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7742           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7743         enddo
7744         call flush(iout)
7745       endif
7746    30 continue
7747 #endif
7748       if (lprn) then
7749         write (iout,'(a)') 'Contact function values:'
7750         do i=nnt,nct-2
7751           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7752           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7753           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7754         enddo
7755       endif
7756       ecorr=0.0D0
7757       ecorr5=0.0d0
7758       ecorr6=0.0d0
7759
7760 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7761 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7762 ! Remove the loop below after debugging !!!
7763       do i=nnt,nct
7764         do j=1,3
7765           gradcorr(j,i)=0.0D0
7766           gradxorr(j,i)=0.0D0
7767         enddo
7768       enddo
7769 ! Calculate the dipole-dipole interaction energies
7770       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7771       do i=iatel_s,iatel_e+1
7772         num_conti=num_cont_hb(i)
7773         do jj=1,num_conti
7774           j=jcont_hb(jj,i)
7775 #ifdef MOMENT
7776           call dipole(i,j,jj)
7777 #endif
7778         enddo
7779       enddo
7780       endif
7781 ! Calculate the local-electrostatic correlation terms
7782 !                write (iout,*) "gradcorr5 in eello5 before loop"
7783 !                do iii=1,nres
7784 !                  write (iout,'(i5,3f10.5)')
7785 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7786 !                enddo
7787       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7788 !        write (iout,*) "corr loop i",i
7789         i1=i+1
7790         num_conti=num_cont_hb(i)
7791         num_conti1=num_cont_hb(i+1)
7792         do jj=1,num_conti
7793           j=jcont_hb(jj,i)
7794           jp=iabs(j)
7795           do kk=1,num_conti1
7796             j1=jcont_hb(kk,i1)
7797             jp1=iabs(j1)
7798 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7799 !     &         ' jj=',jj,' kk=',kk
7800 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7801             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7802                 .or. j.lt.0 .and. j1.gt.0) .and. &
7803                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7804 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7805 ! The system gains extra energy.
7806               n_corr=n_corr+1
7807               sqd1=dsqrt(d_cont(jj,i))
7808               sqd2=dsqrt(d_cont(kk,i1))
7809               sred_geom = sqd1*sqd2
7810               IF (sred_geom.lt.cutoff_corr) THEN
7811                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7812                   ekont,fprimcont)
7813 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7814 !d     &         ' jj=',jj,' kk=',kk
7815                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7816                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7817                 do l=1,3
7818                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7819                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7820                 enddo
7821                 n_corr1=n_corr1+1
7822 !d               write (iout,*) 'sred_geom=',sred_geom,
7823 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7824 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7825 !d               write (iout,*) "g_contij",g_contij
7826 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7827 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7828                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7829                 if (wcorr4.gt.0.0d0) &
7830                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7831                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7832                        write (iout,'(a6,4i5,0pf7.3)') &
7833                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7834 !                write (iout,*) "gradcorr5 before eello5"
7835 !                do iii=1,nres
7836 !                  write (iout,'(i5,3f10.5)')
7837 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7838 !                enddo
7839                 if (wcorr5.gt.0.0d0) &
7840                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7841 !                write (iout,*) "gradcorr5 after eello5"
7842 !                do iii=1,nres
7843 !                  write (iout,'(i5,3f10.5)')
7844 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7845 !                enddo
7846                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7847                        write (iout,'(a6,4i5,0pf7.3)') &
7848                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7849 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7850 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7851                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7852                      .or. wturn6.eq.0.0d0))then
7853 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7854                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7855                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7856                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7857 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7858 !d     &            'ecorr6=',ecorr6
7859 !d                write (iout,'(4e15.5)') sred_geom,
7860 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7861 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7862 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7863                 else if (wturn6.gt.0.0d0 &
7864                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7865 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7866                   eturn6=eturn6+eello_turn6(i,jj,kk)
7867                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7868                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7869 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7870                 endif
7871               ENDIF
7872 1111          continue
7873             endif
7874           enddo ! kk
7875         enddo ! jj
7876       enddo ! i
7877       do i=1,nres
7878         num_cont_hb(i)=num_cont_hb_old(i)
7879       enddo
7880 !                write (iout,*) "gradcorr5 in eello5"
7881 !                do iii=1,nres
7882 !                  write (iout,'(i5,3f10.5)')
7883 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7884 !                enddo
7885       return
7886       end subroutine multibody_eello
7887 !-----------------------------------------------------------------------------
7888       subroutine add_hb_contact_eello(ii,jj,itask)
7889 !      implicit real*8 (a-h,o-z)
7890 !      include "DIMENSIONS"
7891 !      include "COMMON.IOUNITS"
7892 !      include "COMMON.CONTACTS"
7893 !      integer,parameter :: maxconts=nres/4
7894       integer,parameter :: max_dim=70
7895       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7896 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7897 !      common /przechowalnia/ zapas
7898
7899       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7900       integer,dimension(4) ::itask
7901 !      write (iout,*) "itask",itask
7902       do i=1,2
7903         iproc=itask(i)
7904         if (iproc.gt.0) then
7905           do j=1,num_cont_hb(ii)
7906             jjc=jcont_hb(j,ii)
7907 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7908             if (jjc.eq.jj) then
7909               ncont_sent(iproc)=ncont_sent(iproc)+1
7910               nn=ncont_sent(iproc)
7911               zapas(1,nn,iproc)=ii
7912               zapas(2,nn,iproc)=jjc
7913               zapas(3,nn,iproc)=d_cont(j,ii)
7914               ind=3
7915               do kk=1,3
7916                 ind=ind+1
7917                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7918               enddo
7919               do kk=1,2
7920                 do ll=1,2
7921                   ind=ind+1
7922                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7923                 enddo
7924               enddo
7925               do jj=1,5
7926                 do kk=1,3
7927                   do ll=1,2
7928                     do mm=1,2
7929                       ind=ind+1
7930                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7931                     enddo
7932                   enddo
7933                 enddo
7934               enddo
7935               exit
7936             endif
7937           enddo
7938         endif
7939       enddo
7940       return
7941       end subroutine add_hb_contact_eello
7942 !-----------------------------------------------------------------------------
7943       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7944 !      implicit real*8 (a-h,o-z)
7945 !      include 'DIMENSIONS'
7946 !      include 'COMMON.IOUNITS'
7947 !      include 'COMMON.DERIV'
7948 !      include 'COMMON.INTERACT'
7949 !      include 'COMMON.CONTACTS'
7950       real(kind=8),dimension(3) :: gx,gx1
7951       logical :: lprn
7952 !el local variables
7953       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
7954       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
7955                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
7956                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
7957                    rlocshield
7958
7959       lprn=.false.
7960       eij=facont_hb(jj,i)
7961       ekl=facont_hb(kk,k)
7962       ees0pij=ees0p(jj,i)
7963       ees0pkl=ees0p(kk,k)
7964       ees0mij=ees0m(jj,i)
7965       ees0mkl=ees0m(kk,k)
7966       ekont=eij*ekl
7967       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7968 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7969 ! Following 4 lines for diagnostics.
7970 !d    ees0pkl=0.0D0
7971 !d    ees0pij=1.0D0
7972 !d    ees0mkl=0.0D0
7973 !d    ees0mij=1.0D0
7974 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7975 !     & 'Contacts ',i,j,
7976 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7977 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7978 !     & 'gradcorr_long'
7979 ! Calculate the multi-body contribution to energy.
7980 !      ecorr=ecorr+ekont*ees
7981 ! Calculate multi-body contributions to the gradient.
7982       coeffpees0pij=coeffp*ees0pij
7983       coeffmees0mij=coeffm*ees0mij
7984       coeffpees0pkl=coeffp*ees0pkl
7985       coeffmees0mkl=coeffm*ees0mkl
7986       do ll=1,3
7987 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7988         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
7989         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
7990         coeffmees0mkl*gacontm_hb1(ll,jj,i))
7991         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
7992         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
7993         coeffmees0mkl*gacontm_hb2(ll,jj,i))
7994 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7995         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
7996         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
7997         coeffmees0mij*gacontm_hb1(ll,kk,k))
7998         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
7999         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8000         coeffmees0mij*gacontm_hb2(ll,kk,k))
8001         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8002            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8003            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8004         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8005         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8006         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8007            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8008            coeffmees0mij*gacontm_hb3(ll,kk,k))
8009         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8010         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8011 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8012       enddo
8013 !      write (iout,*)
8014 !grad      do m=i+1,j-1
8015 !grad        do ll=1,3
8016 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8017 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8018 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8019 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8020 !grad        enddo
8021 !grad      enddo
8022 !grad      do m=k+1,l-1
8023 !grad        do ll=1,3
8024 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8025 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8026 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8027 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8028 !grad        enddo
8029 !grad      enddo
8030 !      write (iout,*) "ehbcorr",ekont*ees
8031       ehbcorr=ekont*ees
8032       if (shield_mode.gt.0) then
8033        j=ees0plist(jj,i)
8034        l=ees0plist(kk,k)
8035 !C        print *,i,j,fac_shield(i),fac_shield(j),
8036 !C     &fac_shield(k),fac_shield(l)
8037         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8038            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8039           do ilist=1,ishield_list(i)
8040            iresshield=shield_list(ilist,i)
8041            do m=1,3
8042            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8043            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8044                    rlocshield  &
8045             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8046             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8047             +rlocshield
8048            enddo
8049           enddo
8050           do ilist=1,ishield_list(j)
8051            iresshield=shield_list(ilist,j)
8052            do m=1,3
8053            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8054            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8055                    rlocshield &
8056             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8057            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8058             +rlocshield
8059            enddo
8060           enddo
8061
8062           do ilist=1,ishield_list(k)
8063            iresshield=shield_list(ilist,k)
8064            do m=1,3
8065            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8066            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8067                    rlocshield &
8068             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8069            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8070             +rlocshield
8071            enddo
8072           enddo
8073           do ilist=1,ishield_list(l)
8074            iresshield=shield_list(ilist,l)
8075            do m=1,3
8076            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8077            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8078                    rlocshield &
8079             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8080            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8081             +rlocshield
8082            enddo
8083           enddo
8084           do m=1,3
8085             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8086                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8087             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8088                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8089             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8090                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8091             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8092                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8093
8094             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8095                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8096             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8097                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8098             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8099                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8100             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8101                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8102
8103            enddo
8104       endif
8105       endif
8106       return
8107       end function ehbcorr
8108 #ifdef MOMENT
8109 !-----------------------------------------------------------------------------
8110       subroutine dipole(i,j,jj)
8111 !      implicit real*8 (a-h,o-z)
8112 !      include 'DIMENSIONS'
8113 !      include 'COMMON.IOUNITS'
8114 !      include 'COMMON.CHAIN'
8115 !      include 'COMMON.FFIELD'
8116 !      include 'COMMON.DERIV'
8117 !      include 'COMMON.INTERACT'
8118 !      include 'COMMON.CONTACTS'
8119 !      include 'COMMON.TORSION'
8120 !      include 'COMMON.VAR'
8121 !      include 'COMMON.GEO'
8122       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8123       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8124       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8125
8126       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8127       allocate(dipderx(3,5,4,maxconts,nres))
8128 !
8129
8130       iti1 = itortyp(itype(i+1,1))
8131       if (j.lt.nres-1) then
8132         itj1 = itortyp(itype(j+1,1))
8133       else
8134         itj1=ntortyp+1
8135       endif
8136       do iii=1,2
8137         dipi(iii,1)=Ub2(iii,i)
8138         dipderi(iii)=Ub2der(iii,i)
8139         dipi(iii,2)=b1(iii,iti1)
8140         dipj(iii,1)=Ub2(iii,j)
8141         dipderj(iii)=Ub2der(iii,j)
8142         dipj(iii,2)=b1(iii,itj1)
8143       enddo
8144       kkk=0
8145       do iii=1,2
8146         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8147         do jjj=1,2
8148           kkk=kkk+1
8149           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8150         enddo
8151       enddo
8152       do kkk=1,5
8153         do lll=1,3
8154           mmm=0
8155           do iii=1,2
8156             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8157               auxvec(1))
8158             do jjj=1,2
8159               mmm=mmm+1
8160               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8161             enddo
8162           enddo
8163         enddo
8164       enddo
8165       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8166       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8167       do iii=1,2
8168         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8169       enddo
8170       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8171       do iii=1,2
8172         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8173       enddo
8174       return
8175       end subroutine dipole
8176 #endif
8177 !-----------------------------------------------------------------------------
8178       subroutine calc_eello(i,j,k,l,jj,kk)
8179 !
8180 ! This subroutine computes matrices and vectors needed to calculate
8181 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8182 !
8183       use comm_kut
8184 !      implicit real*8 (a-h,o-z)
8185 !      include 'DIMENSIONS'
8186 !      include 'COMMON.IOUNITS'
8187 !      include 'COMMON.CHAIN'
8188 !      include 'COMMON.DERIV'
8189 !      include 'COMMON.INTERACT'
8190 !      include 'COMMON.CONTACTS'
8191 !      include 'COMMON.TORSION'
8192 !      include 'COMMON.VAR'
8193 !      include 'COMMON.GEO'
8194 !      include 'COMMON.FFIELD'
8195       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8196       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8197       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8198               itj1
8199 !el      logical :: lprn
8200 !el      common /kutas/ lprn
8201 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8202 !d     & ' jj=',jj,' kk=',kk
8203 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8204 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8205 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8206       do iii=1,2
8207         do jjj=1,2
8208           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8209           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8210         enddo
8211       enddo
8212       call transpose2(aa1(1,1),aa1t(1,1))
8213       call transpose2(aa2(1,1),aa2t(1,1))
8214       do kkk=1,5
8215         do lll=1,3
8216           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8217             aa1tder(1,1,lll,kkk))
8218           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8219             aa2tder(1,1,lll,kkk))
8220         enddo
8221       enddo
8222       if (l.eq.j+1) then
8223 ! parallel orientation of the two CA-CA-CA frames.
8224         if (i.gt.1) then
8225           iti=itortyp(itype(i,1))
8226         else
8227           iti=ntortyp+1
8228         endif
8229         itk1=itortyp(itype(k+1,1))
8230         itj=itortyp(itype(j,1))
8231         if (l.lt.nres-1) then
8232           itl1=itortyp(itype(l+1,1))
8233         else
8234           itl1=ntortyp+1
8235         endif
8236 ! A1 kernel(j+1) A2T
8237 !d        do iii=1,2
8238 !d          write (iout,'(3f10.5,5x,3f10.5)')
8239 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8240 !d        enddo
8241         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8242          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8243          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8244 ! Following matrices are needed only for 6-th order cumulants
8245         IF (wcorr6.gt.0.0d0) THEN
8246         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8247          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8248          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8249         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8250          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8251          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8252          ADtEAderx(1,1,1,1,1,1))
8253         lprn=.false.
8254         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8255          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8256          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8257          ADtEA1derx(1,1,1,1,1,1))
8258         ENDIF
8259 ! End 6-th order cumulants
8260 !d        lprn=.false.
8261 !d        if (lprn) then
8262 !d        write (2,*) 'In calc_eello6'
8263 !d        do iii=1,2
8264 !d          write (2,*) 'iii=',iii
8265 !d          do kkk=1,5
8266 !d            write (2,*) 'kkk=',kkk
8267 !d            do jjj=1,2
8268 !d              write (2,'(3(2f10.5),5x)')
8269 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8270 !d            enddo
8271 !d          enddo
8272 !d        enddo
8273 !d        endif
8274         call transpose2(EUgder(1,1,k),auxmat(1,1))
8275         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8276         call transpose2(EUg(1,1,k),auxmat(1,1))
8277         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8278         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8279         do iii=1,2
8280           do kkk=1,5
8281             do lll=1,3
8282               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8283                 EAEAderx(1,1,lll,kkk,iii,1))
8284             enddo
8285           enddo
8286         enddo
8287 ! A1T kernel(i+1) A2
8288         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8289          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8290          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8291 ! Following matrices are needed only for 6-th order cumulants
8292         IF (wcorr6.gt.0.0d0) THEN
8293         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8294          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8295          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8296         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8297          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8298          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8299          ADtEAderx(1,1,1,1,1,2))
8300         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8301          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8302          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8303          ADtEA1derx(1,1,1,1,1,2))
8304         ENDIF
8305 ! End 6-th order cumulants
8306         call transpose2(EUgder(1,1,l),auxmat(1,1))
8307         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8308         call transpose2(EUg(1,1,l),auxmat(1,1))
8309         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8310         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8311         do iii=1,2
8312           do kkk=1,5
8313             do lll=1,3
8314               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8315                 EAEAderx(1,1,lll,kkk,iii,2))
8316             enddo
8317           enddo
8318         enddo
8319 ! AEAb1 and AEAb2
8320 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8321 ! They are needed only when the fifth- or the sixth-order cumulants are
8322 ! indluded.
8323         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8324         call transpose2(AEA(1,1,1),auxmat(1,1))
8325         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8326         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8327         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8328         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8329         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8330         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8331         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8332         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8333         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8334         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8335         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8336         call transpose2(AEA(1,1,2),auxmat(1,1))
8337         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8338         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8339         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8340         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8341         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8342         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8343         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8344         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8345         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8346         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8347         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8348 ! Calculate the Cartesian derivatives of the vectors.
8349         do iii=1,2
8350           do kkk=1,5
8351             do lll=1,3
8352               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8353               call matvec2(auxmat(1,1),b1(1,iti),&
8354                 AEAb1derx(1,lll,kkk,iii,1,1))
8355               call matvec2(auxmat(1,1),Ub2(1,i),&
8356                 AEAb2derx(1,lll,kkk,iii,1,1))
8357               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8358                 AEAb1derx(1,lll,kkk,iii,2,1))
8359               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8360                 AEAb2derx(1,lll,kkk,iii,2,1))
8361               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8362               call matvec2(auxmat(1,1),b1(1,itj),&
8363                 AEAb1derx(1,lll,kkk,iii,1,2))
8364               call matvec2(auxmat(1,1),Ub2(1,j),&
8365                 AEAb2derx(1,lll,kkk,iii,1,2))
8366               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8367                 AEAb1derx(1,lll,kkk,iii,2,2))
8368               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8369                 AEAb2derx(1,lll,kkk,iii,2,2))
8370             enddo
8371           enddo
8372         enddo
8373         ENDIF
8374 ! End vectors
8375       else
8376 ! Antiparallel orientation of the two CA-CA-CA frames.
8377         if (i.gt.1) then
8378           iti=itortyp(itype(i,1))
8379         else
8380           iti=ntortyp+1
8381         endif
8382         itk1=itortyp(itype(k+1,1))
8383         itl=itortyp(itype(l,1))
8384         itj=itortyp(itype(j,1))
8385         if (j.lt.nres-1) then
8386           itj1=itortyp(itype(j+1,1))
8387         else
8388           itj1=ntortyp+1
8389         endif
8390 ! A2 kernel(j-1)T A1T
8391         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8392          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8393          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8394 ! Following matrices are needed only for 6-th order cumulants
8395         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8396            j.eq.i+4 .and. l.eq.i+3)) THEN
8397         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8398          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8399          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8400         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8401          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8402          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8403          ADtEAderx(1,1,1,1,1,1))
8404         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8405          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8406          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8407          ADtEA1derx(1,1,1,1,1,1))
8408         ENDIF
8409 ! End 6-th order cumulants
8410         call transpose2(EUgder(1,1,k),auxmat(1,1))
8411         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8412         call transpose2(EUg(1,1,k),auxmat(1,1))
8413         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8414         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8415         do iii=1,2
8416           do kkk=1,5
8417             do lll=1,3
8418               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8419                 EAEAderx(1,1,lll,kkk,iii,1))
8420             enddo
8421           enddo
8422         enddo
8423 ! A2T kernel(i+1)T A1
8424         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8425          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8426          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8427 ! Following matrices are needed only for 6-th order cumulants
8428         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8429            j.eq.i+4 .and. l.eq.i+3)) THEN
8430         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8431          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8432          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8433         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8434          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8435          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8436          ADtEAderx(1,1,1,1,1,2))
8437         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8438          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8439          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8440          ADtEA1derx(1,1,1,1,1,2))
8441         ENDIF
8442 ! End 6-th order cumulants
8443         call transpose2(EUgder(1,1,j),auxmat(1,1))
8444         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8445         call transpose2(EUg(1,1,j),auxmat(1,1))
8446         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8447         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8448         do iii=1,2
8449           do kkk=1,5
8450             do lll=1,3
8451               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8452                 EAEAderx(1,1,lll,kkk,iii,2))
8453             enddo
8454           enddo
8455         enddo
8456 ! AEAb1 and AEAb2
8457 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8458 ! They are needed only when the fifth- or the sixth-order cumulants are
8459 ! indluded.
8460         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8461           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8462         call transpose2(AEA(1,1,1),auxmat(1,1))
8463         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8464         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8465         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8466         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8467         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8468         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8469         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8470         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8471         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8472         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8473         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8474         call transpose2(AEA(1,1,2),auxmat(1,1))
8475         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8476         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8477         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8478         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8479         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8480         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8481         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8482         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8483         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8484         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8485         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8486 ! Calculate the Cartesian derivatives of the vectors.
8487         do iii=1,2
8488           do kkk=1,5
8489             do lll=1,3
8490               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8491               call matvec2(auxmat(1,1),b1(1,iti),&
8492                 AEAb1derx(1,lll,kkk,iii,1,1))
8493               call matvec2(auxmat(1,1),Ub2(1,i),&
8494                 AEAb2derx(1,lll,kkk,iii,1,1))
8495               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8496                 AEAb1derx(1,lll,kkk,iii,2,1))
8497               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8498                 AEAb2derx(1,lll,kkk,iii,2,1))
8499               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8500               call matvec2(auxmat(1,1),b1(1,itl),&
8501                 AEAb1derx(1,lll,kkk,iii,1,2))
8502               call matvec2(auxmat(1,1),Ub2(1,l),&
8503                 AEAb2derx(1,lll,kkk,iii,1,2))
8504               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8505                 AEAb1derx(1,lll,kkk,iii,2,2))
8506               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8507                 AEAb2derx(1,lll,kkk,iii,2,2))
8508             enddo
8509           enddo
8510         enddo
8511         ENDIF
8512 ! End vectors
8513       endif
8514       return
8515       end subroutine calc_eello
8516 !-----------------------------------------------------------------------------
8517       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8518       use comm_kut
8519       implicit none
8520       integer :: nderg
8521       logical :: transp
8522       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8523       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8524       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8525       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8526       integer :: iii,kkk,lll
8527       integer :: jjj,mmm
8528 !el      logical :: lprn
8529 !el      common /kutas/ lprn
8530       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8531       do iii=1,nderg
8532         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8533           AKAderg(1,1,iii))
8534       enddo
8535 !d      if (lprn) write (2,*) 'In kernel'
8536       do kkk=1,5
8537 !d        if (lprn) write (2,*) 'kkk=',kkk
8538         do lll=1,3
8539           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8540             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8541 !d          if (lprn) then
8542 !d            write (2,*) 'lll=',lll
8543 !d            write (2,*) 'iii=1'
8544 !d            do jjj=1,2
8545 !d              write (2,'(3(2f10.5),5x)')
8546 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8547 !d            enddo
8548 !d          endif
8549           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8550             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8551 !d          if (lprn) then
8552 !d            write (2,*) 'lll=',lll
8553 !d            write (2,*) 'iii=2'
8554 !d            do jjj=1,2
8555 !d              write (2,'(3(2f10.5),5x)')
8556 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8557 !d            enddo
8558 !d          endif
8559         enddo
8560       enddo
8561       return
8562       end subroutine kernel
8563 !-----------------------------------------------------------------------------
8564       real(kind=8) function eello4(i,j,k,l,jj,kk)
8565 !      implicit real*8 (a-h,o-z)
8566 !      include 'DIMENSIONS'
8567 !      include 'COMMON.IOUNITS'
8568 !      include 'COMMON.CHAIN'
8569 !      include 'COMMON.DERIV'
8570 !      include 'COMMON.INTERACT'
8571 !      include 'COMMON.CONTACTS'
8572 !      include 'COMMON.TORSION'
8573 !      include 'COMMON.VAR'
8574 !      include 'COMMON.GEO'
8575       real(kind=8),dimension(2,2) :: pizda
8576       real(kind=8),dimension(3) :: ggg1,ggg2
8577       real(kind=8) ::  eel4,glongij,glongkl
8578       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8579 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8580 !d        eello4=0.0d0
8581 !d        return
8582 !d      endif
8583 !d      print *,'eello4:',i,j,k,l,jj,kk
8584 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8585 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8586 !old      eij=facont_hb(jj,i)
8587 !old      ekl=facont_hb(kk,k)
8588 !old      ekont=eij*ekl
8589       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8590 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8591       gcorr_loc(k-1)=gcorr_loc(k-1) &
8592          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8593       if (l.eq.j+1) then
8594         gcorr_loc(l-1)=gcorr_loc(l-1) &
8595            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8596       else
8597         gcorr_loc(j-1)=gcorr_loc(j-1) &
8598            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8599       endif
8600       do iii=1,2
8601         do kkk=1,5
8602           do lll=1,3
8603             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8604                               -EAEAderx(2,2,lll,kkk,iii,1)
8605 !d            derx(lll,kkk,iii)=0.0d0
8606           enddo
8607         enddo
8608       enddo
8609 !d      gcorr_loc(l-1)=0.0d0
8610 !d      gcorr_loc(j-1)=0.0d0
8611 !d      gcorr_loc(k-1)=0.0d0
8612 !d      eel4=1.0d0
8613 !d      write (iout,*)'Contacts have occurred for peptide groups',
8614 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8615 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8616       if (j.lt.nres-1) then
8617         j1=j+1
8618         j2=j-1
8619       else
8620         j1=j-1
8621         j2=j-2
8622       endif
8623       if (l.lt.nres-1) then
8624         l1=l+1
8625         l2=l-1
8626       else
8627         l1=l-1
8628         l2=l-2
8629       endif
8630       do ll=1,3
8631 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8632 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8633         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8634         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8635 !grad        ghalf=0.5d0*ggg1(ll)
8636         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8637         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8638         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8639         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8640         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8641         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8642 !grad        ghalf=0.5d0*ggg2(ll)
8643         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8644         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8645         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8646         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8647         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8648         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8649       enddo
8650 !grad      do m=i+1,j-1
8651 !grad        do ll=1,3
8652 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8653 !grad        enddo
8654 !grad      enddo
8655 !grad      do m=k+1,l-1
8656 !grad        do ll=1,3
8657 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8658 !grad        enddo
8659 !grad      enddo
8660 !grad      do m=i+2,j2
8661 !grad        do ll=1,3
8662 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8663 !grad        enddo
8664 !grad      enddo
8665 !grad      do m=k+2,l2
8666 !grad        do ll=1,3
8667 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8668 !grad        enddo
8669 !grad      enddo
8670 !d      do iii=1,nres-3
8671 !d        write (2,*) iii,gcorr_loc(iii)
8672 !d      enddo
8673       eello4=ekont*eel4
8674 !d      write (2,*) 'ekont',ekont
8675 !d      write (iout,*) 'eello4',ekont*eel4
8676       return
8677       end function eello4
8678 !-----------------------------------------------------------------------------
8679       real(kind=8) function eello5(i,j,k,l,jj,kk)
8680 !      implicit real*8 (a-h,o-z)
8681 !      include 'DIMENSIONS'
8682 !      include 'COMMON.IOUNITS'
8683 !      include 'COMMON.CHAIN'
8684 !      include 'COMMON.DERIV'
8685 !      include 'COMMON.INTERACT'
8686 !      include 'COMMON.CONTACTS'
8687 !      include 'COMMON.TORSION'
8688 !      include 'COMMON.VAR'
8689 !      include 'COMMON.GEO'
8690       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8691       real(kind=8),dimension(2) :: vv
8692       real(kind=8),dimension(3) :: ggg1,ggg2
8693       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8694       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8695       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8696 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8697 !                                                                              C
8698 !                            Parallel chains                                   C
8699 !                                                                              C
8700 !          o             o                   o             o                   C
8701 !         /l\           / \             \   / \           / \   /              C
8702 !        /   \         /   \             \ /   \         /   \ /               C
8703 !       j| o |l1       | o |                o| o |         | o |o                C
8704 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8705 !      \i/   \         /   \ /             /   \         /   \                 C
8706 !       o    k1             o                                                  C
8707 !         (I)          (II)                (III)          (IV)                 C
8708 !                                                                              C
8709 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8710 !                                                                              C
8711 !                            Antiparallel chains                               C
8712 !                                                                              C
8713 !          o             o                   o             o                   C
8714 !         /j\           / \             \   / \           / \   /              C
8715 !        /   \         /   \             \ /   \         /   \ /               C
8716 !      j1| o |l        | o |                o| o |         | o |o                C
8717 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8718 !      \i/   \         /   \ /             /   \         /   \                 C
8719 !       o     k1            o                                                  C
8720 !         (I)          (II)                (III)          (IV)                 C
8721 !                                                                              C
8722 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8723 !                                                                              C
8724 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8725 !                                                                              C
8726 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8727 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8728 !d        eello5=0.0d0
8729 !d        return
8730 !d      endif
8731 !d      write (iout,*)
8732 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8733 !d     &   ' and',k,l
8734       itk=itortyp(itype(k,1))
8735       itl=itortyp(itype(l,1))
8736       itj=itortyp(itype(j,1))
8737       eello5_1=0.0d0
8738       eello5_2=0.0d0
8739       eello5_3=0.0d0
8740       eello5_4=0.0d0
8741 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8742 !d     &   eel5_3_num,eel5_4_num)
8743       do iii=1,2
8744         do kkk=1,5
8745           do lll=1,3
8746             derx(lll,kkk,iii)=0.0d0
8747           enddo
8748         enddo
8749       enddo
8750 !d      eij=facont_hb(jj,i)
8751 !d      ekl=facont_hb(kk,k)
8752 !d      ekont=eij*ekl
8753 !d      write (iout,*)'Contacts have occurred for peptide groups',
8754 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8755 !d      goto 1111
8756 ! Contribution from the graph I.
8757 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8758 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8759       call transpose2(EUg(1,1,k),auxmat(1,1))
8760       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8761       vv(1)=pizda(1,1)-pizda(2,2)
8762       vv(2)=pizda(1,2)+pizda(2,1)
8763       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8764        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8765 ! Explicit gradient in virtual-dihedral angles.
8766       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8767        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8768        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8769       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8770       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8771       vv(1)=pizda(1,1)-pizda(2,2)
8772       vv(2)=pizda(1,2)+pizda(2,1)
8773       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8774        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8775        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8776       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8777       vv(1)=pizda(1,1)-pizda(2,2)
8778       vv(2)=pizda(1,2)+pizda(2,1)
8779       if (l.eq.j+1) then
8780         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8781          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8782          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8783       else
8784         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8785          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8786          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8787       endif
8788 ! Cartesian gradient
8789       do iii=1,2
8790         do kkk=1,5
8791           do lll=1,3
8792             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8793               pizda(1,1))
8794             vv(1)=pizda(1,1)-pizda(2,2)
8795             vv(2)=pizda(1,2)+pizda(2,1)
8796             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8797              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8798              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8799           enddo
8800         enddo
8801       enddo
8802 !      goto 1112
8803 !1111  continue
8804 ! Contribution from graph II
8805       call transpose2(EE(1,1,itk),auxmat(1,1))
8806       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8807       vv(1)=pizda(1,1)+pizda(2,2)
8808       vv(2)=pizda(2,1)-pizda(1,2)
8809       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8810        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8811 ! Explicit gradient in virtual-dihedral angles.
8812       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8813        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8814       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8815       vv(1)=pizda(1,1)+pizda(2,2)
8816       vv(2)=pizda(2,1)-pizda(1,2)
8817       if (l.eq.j+1) then
8818         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8819          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8820          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8821       else
8822         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8823          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8824          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8825       endif
8826 ! Cartesian gradient
8827       do iii=1,2
8828         do kkk=1,5
8829           do lll=1,3
8830             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8831               pizda(1,1))
8832             vv(1)=pizda(1,1)+pizda(2,2)
8833             vv(2)=pizda(2,1)-pizda(1,2)
8834             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8835              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8836              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8837           enddo
8838         enddo
8839       enddo
8840 !d      goto 1112
8841 !d1111  continue
8842       if (l.eq.j+1) then
8843 !d        goto 1110
8844 ! Parallel orientation
8845 ! Contribution from graph III
8846         call transpose2(EUg(1,1,l),auxmat(1,1))
8847         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8848         vv(1)=pizda(1,1)-pizda(2,2)
8849         vv(2)=pizda(1,2)+pizda(2,1)
8850         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8851          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8852 ! Explicit gradient in virtual-dihedral angles.
8853         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8854          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8855          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8856         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8857         vv(1)=pizda(1,1)-pizda(2,2)
8858         vv(2)=pizda(1,2)+pizda(2,1)
8859         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8860          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8861          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8862         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8863         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8864         vv(1)=pizda(1,1)-pizda(2,2)
8865         vv(2)=pizda(1,2)+pizda(2,1)
8866         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8867          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8868          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8869 ! Cartesian gradient
8870         do iii=1,2
8871           do kkk=1,5
8872             do lll=1,3
8873               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8874                 pizda(1,1))
8875               vv(1)=pizda(1,1)-pizda(2,2)
8876               vv(2)=pizda(1,2)+pizda(2,1)
8877               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8878                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8879                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8880             enddo
8881           enddo
8882         enddo
8883 !d        goto 1112
8884 ! Contribution from graph IV
8885 !d1110    continue
8886         call transpose2(EE(1,1,itl),auxmat(1,1))
8887         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8888         vv(1)=pizda(1,1)+pizda(2,2)
8889         vv(2)=pizda(2,1)-pizda(1,2)
8890         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8891          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8892 ! Explicit gradient in virtual-dihedral angles.
8893         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8894          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8895         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8896         vv(1)=pizda(1,1)+pizda(2,2)
8897         vv(2)=pizda(2,1)-pizda(1,2)
8898         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8899          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8900          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8901 ! Cartesian gradient
8902         do iii=1,2
8903           do kkk=1,5
8904             do lll=1,3
8905               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8906                 pizda(1,1))
8907               vv(1)=pizda(1,1)+pizda(2,2)
8908               vv(2)=pizda(2,1)-pizda(1,2)
8909               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8910                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8911                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8912             enddo
8913           enddo
8914         enddo
8915       else
8916 ! Antiparallel orientation
8917 ! Contribution from graph III
8918 !        goto 1110
8919         call transpose2(EUg(1,1,j),auxmat(1,1))
8920         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8921         vv(1)=pizda(1,1)-pizda(2,2)
8922         vv(2)=pizda(1,2)+pizda(2,1)
8923         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8924          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8925 ! Explicit gradient in virtual-dihedral angles.
8926         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8927          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8928          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8929         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8930         vv(1)=pizda(1,1)-pizda(2,2)
8931         vv(2)=pizda(1,2)+pizda(2,1)
8932         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8933          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
8934          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8935         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8936         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8937         vv(1)=pizda(1,1)-pizda(2,2)
8938         vv(2)=pizda(1,2)+pizda(2,1)
8939         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8940          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
8941          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8942 ! Cartesian gradient
8943         do iii=1,2
8944           do kkk=1,5
8945             do lll=1,3
8946               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8947                 pizda(1,1))
8948               vv(1)=pizda(1,1)-pizda(2,2)
8949               vv(2)=pizda(1,2)+pizda(2,1)
8950               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8951                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
8952                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8953             enddo
8954           enddo
8955         enddo
8956 !d        goto 1112
8957 ! Contribution from graph IV
8958 1110    continue
8959         call transpose2(EE(1,1,itj),auxmat(1,1))
8960         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8961         vv(1)=pizda(1,1)+pizda(2,2)
8962         vv(2)=pizda(2,1)-pizda(1,2)
8963         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
8964          -0.5d0*scalar2(vv(1),Ctobr(1,j))
8965 ! Explicit gradient in virtual-dihedral angles.
8966         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8967          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8968         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8969         vv(1)=pizda(1,1)+pizda(2,2)
8970         vv(2)=pizda(2,1)-pizda(1,2)
8971         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8972          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
8973          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8974 ! Cartesian gradient
8975         do iii=1,2
8976           do kkk=1,5
8977             do lll=1,3
8978               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8979                 pizda(1,1))
8980               vv(1)=pizda(1,1)+pizda(2,2)
8981               vv(2)=pizda(2,1)-pizda(1,2)
8982               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8983                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
8984                -0.5d0*scalar2(vv(1),Ctobr(1,j))
8985             enddo
8986           enddo
8987         enddo
8988       endif
8989 1112  continue
8990       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8991 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8992 !d        write (2,*) 'ijkl',i,j,k,l
8993 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8994 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8995 !d      endif
8996 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8997 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8998 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8999 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9000       if (j.lt.nres-1) then
9001         j1=j+1
9002         j2=j-1
9003       else
9004         j1=j-1
9005         j2=j-2
9006       endif
9007       if (l.lt.nres-1) then
9008         l1=l+1
9009         l2=l-1
9010       else
9011         l1=l-1
9012         l2=l-2
9013       endif
9014 !d      eij=1.0d0
9015 !d      ekl=1.0d0
9016 !d      ekont=1.0d0
9017 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9018 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9019 !        summed up outside the subrouine as for the other subroutines
9020 !        handling long-range interactions. The old code is commented out
9021 !        with "cgrad" to keep track of changes.
9022       do ll=1,3
9023 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9024 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9025         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9026         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9027 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9028 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9029 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9030 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9031 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9032 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9033 !     &   gradcorr5ij,
9034 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9035 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9036 !grad        ghalf=0.5d0*ggg1(ll)
9037 !d        ghalf=0.0d0
9038         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9039         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9040         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9041         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9042         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9043         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9044 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9045 !grad        ghalf=0.5d0*ggg2(ll)
9046         ghalf=0.0d0
9047         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9048         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9049         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9050         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9051         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9052         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9053       enddo
9054 !d      goto 1112
9055 !grad      do m=i+1,j-1
9056 !grad        do ll=1,3
9057 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9058 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9059 !grad        enddo
9060 !grad      enddo
9061 !grad      do m=k+1,l-1
9062 !grad        do ll=1,3
9063 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9064 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9065 !grad        enddo
9066 !grad      enddo
9067 !1112  continue
9068 !grad      do m=i+2,j2
9069 !grad        do ll=1,3
9070 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9071 !grad        enddo
9072 !grad      enddo
9073 !grad      do m=k+2,l2
9074 !grad        do ll=1,3
9075 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9076 !grad        enddo
9077 !grad      enddo
9078 !d      do iii=1,nres-3
9079 !d        write (2,*) iii,g_corr5_loc(iii)
9080 !d      enddo
9081       eello5=ekont*eel5
9082 !d      write (2,*) 'ekont',ekont
9083 !d      write (iout,*) 'eello5',ekont*eel5
9084       return
9085       end function eello5
9086 !-----------------------------------------------------------------------------
9087       real(kind=8) function eello6(i,j,k,l,jj,kk)
9088 !      implicit real*8 (a-h,o-z)
9089 !      include 'DIMENSIONS'
9090 !      include 'COMMON.IOUNITS'
9091 !      include 'COMMON.CHAIN'
9092 !      include 'COMMON.DERIV'
9093 !      include 'COMMON.INTERACT'
9094 !      include 'COMMON.CONTACTS'
9095 !      include 'COMMON.TORSION'
9096 !      include 'COMMON.VAR'
9097 !      include 'COMMON.GEO'
9098 !      include 'COMMON.FFIELD'
9099       real(kind=8),dimension(3) :: ggg1,ggg2
9100       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9101                    eello6_6,eel6
9102       real(kind=8) :: gradcorr6ij,gradcorr6kl
9103       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9104 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9105 !d        eello6=0.0d0
9106 !d        return
9107 !d      endif
9108 !d      write (iout,*)
9109 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9110 !d     &   ' and',k,l
9111       eello6_1=0.0d0
9112       eello6_2=0.0d0
9113       eello6_3=0.0d0
9114       eello6_4=0.0d0
9115       eello6_5=0.0d0
9116       eello6_6=0.0d0
9117 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9118 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9119       do iii=1,2
9120         do kkk=1,5
9121           do lll=1,3
9122             derx(lll,kkk,iii)=0.0d0
9123           enddo
9124         enddo
9125       enddo
9126 !d      eij=facont_hb(jj,i)
9127 !d      ekl=facont_hb(kk,k)
9128 !d      ekont=eij*ekl
9129 !d      eij=1.0d0
9130 !d      ekl=1.0d0
9131 !d      ekont=1.0d0
9132       if (l.eq.j+1) then
9133         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9134         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9135         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9136         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9137         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9138         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9139       else
9140         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9141         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9142         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9143         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9144         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9145           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9146         else
9147           eello6_5=0.0d0
9148         endif
9149         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9150       endif
9151 ! If turn contributions are considered, they will be handled separately.
9152       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9153 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9154 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9155 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9156 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9157 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9158 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9159 !d      goto 1112
9160       if (j.lt.nres-1) then
9161         j1=j+1
9162         j2=j-1
9163       else
9164         j1=j-1
9165         j2=j-2
9166       endif
9167       if (l.lt.nres-1) then
9168         l1=l+1
9169         l2=l-1
9170       else
9171         l1=l-1
9172         l2=l-2
9173       endif
9174       do ll=1,3
9175 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9176 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9177 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9178 !grad        ghalf=0.5d0*ggg1(ll)
9179 !d        ghalf=0.0d0
9180         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9181         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9182         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9183         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9184         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9185         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9186         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9187         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9188 !grad        ghalf=0.5d0*ggg2(ll)
9189 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9190 !d        ghalf=0.0d0
9191         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9192         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9193         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9194         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9195         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9196         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9197       enddo
9198 !d      goto 1112
9199 !grad      do m=i+1,j-1
9200 !grad        do ll=1,3
9201 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9202 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9203 !grad        enddo
9204 !grad      enddo
9205 !grad      do m=k+1,l-1
9206 !grad        do ll=1,3
9207 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9208 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9209 !grad        enddo
9210 !grad      enddo
9211 !grad1112  continue
9212 !grad      do m=i+2,j2
9213 !grad        do ll=1,3
9214 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9215 !grad        enddo
9216 !grad      enddo
9217 !grad      do m=k+2,l2
9218 !grad        do ll=1,3
9219 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9220 !grad        enddo
9221 !grad      enddo
9222 !d      do iii=1,nres-3
9223 !d        write (2,*) iii,g_corr6_loc(iii)
9224 !d      enddo
9225       eello6=ekont*eel6
9226 !d      write (2,*) 'ekont',ekont
9227 !d      write (iout,*) 'eello6',ekont*eel6
9228       return
9229       end function eello6
9230 !-----------------------------------------------------------------------------
9231       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9232       use comm_kut
9233 !      implicit real*8 (a-h,o-z)
9234 !      include 'DIMENSIONS'
9235 !      include 'COMMON.IOUNITS'
9236 !      include 'COMMON.CHAIN'
9237 !      include 'COMMON.DERIV'
9238 !      include 'COMMON.INTERACT'
9239 !      include 'COMMON.CONTACTS'
9240 !      include 'COMMON.TORSION'
9241 !      include 'COMMON.VAR'
9242 !      include 'COMMON.GEO'
9243       real(kind=8),dimension(2) :: vv,vv1
9244       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9245       logical :: swap
9246 !el      logical :: lprn
9247 !el      common /kutas/ lprn
9248       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9249       real(kind=8) :: s1,s2,s3,s4,s5
9250 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9251 !                                                                              C
9252 !      Parallel       Antiparallel                                             C
9253 !                                                                              C
9254 !          o             o                                                     C
9255 !         /l\           /j\                                                    C
9256 !        /   \         /   \                                                   C
9257 !       /| o |         | o |\                                                  C
9258 !     \ j|/k\|  /   \  |/k\|l /                                                C
9259 !      \ /   \ /     \ /   \ /                                                 C
9260 !       o     o       o     o                                                  C
9261 !       i             i                                                        C
9262 !                                                                              C
9263 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9264       itk=itortyp(itype(k,1))
9265       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9266       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9267       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9268       call transpose2(EUgC(1,1,k),auxmat(1,1))
9269       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9270       vv1(1)=pizda1(1,1)-pizda1(2,2)
9271       vv1(2)=pizda1(1,2)+pizda1(2,1)
9272       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9273       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9274       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9275       s5=scalar2(vv(1),Dtobr2(1,i))
9276 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9277       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9278       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9279        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9280        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9281        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9282        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9283        +scalar2(vv(1),Dtobr2der(1,i)))
9284       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9285       vv1(1)=pizda1(1,1)-pizda1(2,2)
9286       vv1(2)=pizda1(1,2)+pizda1(2,1)
9287       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9288       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9289       if (l.eq.j+1) then
9290         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9291        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9292        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9293        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9294        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9295       else
9296         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9297        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9298        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9299        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9300        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9301       endif
9302       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9303       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9304       vv1(1)=pizda1(1,1)-pizda1(2,2)
9305       vv1(2)=pizda1(1,2)+pizda1(2,1)
9306       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9307        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9308        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9309        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9310       do iii=1,2
9311         if (swap) then
9312           ind=3-iii
9313         else
9314           ind=iii
9315         endif
9316         do kkk=1,5
9317           do lll=1,3
9318             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9319             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9320             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9321             call transpose2(EUgC(1,1,k),auxmat(1,1))
9322             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9323               pizda1(1,1))
9324             vv1(1)=pizda1(1,1)-pizda1(2,2)
9325             vv1(2)=pizda1(1,2)+pizda1(2,1)
9326             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9327             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9328              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9329             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9330              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9331             s5=scalar2(vv(1),Dtobr2(1,i))
9332             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9333           enddo
9334         enddo
9335       enddo
9336       return
9337       end function eello6_graph1
9338 !-----------------------------------------------------------------------------
9339       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9340       use comm_kut
9341 !      implicit real*8 (a-h,o-z)
9342 !      include 'DIMENSIONS'
9343 !      include 'COMMON.IOUNITS'
9344 !      include 'COMMON.CHAIN'
9345 !      include 'COMMON.DERIV'
9346 !      include 'COMMON.INTERACT'
9347 !      include 'COMMON.CONTACTS'
9348 !      include 'COMMON.TORSION'
9349 !      include 'COMMON.VAR'
9350 !      include 'COMMON.GEO'
9351       logical :: swap
9352       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9353       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9354 !el      logical :: lprn
9355 !el      common /kutas/ lprn
9356       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9357       real(kind=8) :: s2,s3,s4
9358 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9359 !                                                                              C
9360 !      Parallel       Antiparallel                                             C
9361 !                                                                              C
9362 !          o             o                                                     C
9363 !     \   /l\           /j\   /                                                C
9364 !      \ /   \         /   \ /                                                 C
9365 !       o| o |         | o |o                                                  C
9366 !     \ j|/k\|      \  |/k\|l                                                  C
9367 !      \ /   \       \ /   \                                                   C
9368 !       o             o                                                        C
9369 !       i             i                                                        C
9370 !                                                                              C
9371 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9372 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9373 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9374 !           but not in a cluster cumulant
9375 #ifdef MOMENT
9376       s1=dip(1,jj,i)*dip(1,kk,k)
9377 #endif
9378       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9379       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9380       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9381       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9382       call transpose2(EUg(1,1,k),auxmat(1,1))
9383       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9384       vv(1)=pizda(1,1)-pizda(2,2)
9385       vv(2)=pizda(1,2)+pizda(2,1)
9386       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9387 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9388 #ifdef MOMENT
9389       eello6_graph2=-(s1+s2+s3+s4)
9390 #else
9391       eello6_graph2=-(s2+s3+s4)
9392 #endif
9393 !      eello6_graph2=-s3
9394 ! Derivatives in gamma(i-1)
9395       if (i.gt.1) then
9396 #ifdef MOMENT
9397         s1=dipderg(1,jj,i)*dip(1,kk,k)
9398 #endif
9399         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9400         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9401         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9402         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9403 #ifdef MOMENT
9404         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9405 #else
9406         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9407 #endif
9408 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9409       endif
9410 ! Derivatives in gamma(k-1)
9411 #ifdef MOMENT
9412       s1=dip(1,jj,i)*dipderg(1,kk,k)
9413 #endif
9414       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9415       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9416       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9417       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9418       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9419       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9420       vv(1)=pizda(1,1)-pizda(2,2)
9421       vv(2)=pizda(1,2)+pizda(2,1)
9422       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9423 #ifdef MOMENT
9424       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9425 #else
9426       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9427 #endif
9428 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9429 ! Derivatives in gamma(j-1) or gamma(l-1)
9430       if (j.gt.1) then
9431 #ifdef MOMENT
9432         s1=dipderg(3,jj,i)*dip(1,kk,k)
9433 #endif
9434         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9435         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9436         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9437         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9438         vv(1)=pizda(1,1)-pizda(2,2)
9439         vv(2)=pizda(1,2)+pizda(2,1)
9440         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9441 #ifdef MOMENT
9442         if (swap) then
9443           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9444         else
9445           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9446         endif
9447 #endif
9448         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9449 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9450       endif
9451 ! Derivatives in gamma(l-1) or gamma(j-1)
9452       if (l.gt.1) then
9453 #ifdef MOMENT
9454         s1=dip(1,jj,i)*dipderg(3,kk,k)
9455 #endif
9456         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9457         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9458         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9459         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9460         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9461         vv(1)=pizda(1,1)-pizda(2,2)
9462         vv(2)=pizda(1,2)+pizda(2,1)
9463         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9464 #ifdef MOMENT
9465         if (swap) then
9466           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9467         else
9468           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9469         endif
9470 #endif
9471         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9472 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9473       endif
9474 ! Cartesian derivatives.
9475       if (lprn) then
9476         write (2,*) 'In eello6_graph2'
9477         do iii=1,2
9478           write (2,*) 'iii=',iii
9479           do kkk=1,5
9480             write (2,*) 'kkk=',kkk
9481             do jjj=1,2
9482               write (2,'(3(2f10.5),5x)') &
9483               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9484             enddo
9485           enddo
9486         enddo
9487       endif
9488       do iii=1,2
9489         do kkk=1,5
9490           do lll=1,3
9491 #ifdef MOMENT
9492             if (iii.eq.1) then
9493               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9494             else
9495               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9496             endif
9497 #endif
9498             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9499               auxvec(1))
9500             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9501             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9502               auxvec(1))
9503             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9504             call transpose2(EUg(1,1,k),auxmat(1,1))
9505             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9506               pizda(1,1))
9507             vv(1)=pizda(1,1)-pizda(2,2)
9508             vv(2)=pizda(1,2)+pizda(2,1)
9509             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9510 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9511 #ifdef MOMENT
9512             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9513 #else
9514             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9515 #endif
9516             if (swap) then
9517               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9518             else
9519               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9520             endif
9521           enddo
9522         enddo
9523       enddo
9524       return
9525       end function eello6_graph2
9526 !-----------------------------------------------------------------------------
9527       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9528 !      implicit real*8 (a-h,o-z)
9529 !      include 'DIMENSIONS'
9530 !      include 'COMMON.IOUNITS'
9531 !      include 'COMMON.CHAIN'
9532 !      include 'COMMON.DERIV'
9533 !      include 'COMMON.INTERACT'
9534 !      include 'COMMON.CONTACTS'
9535 !      include 'COMMON.TORSION'
9536 !      include 'COMMON.VAR'
9537 !      include 'COMMON.GEO'
9538       real(kind=8),dimension(2) :: vv,auxvec
9539       real(kind=8),dimension(2,2) :: pizda,auxmat
9540       logical :: swap
9541       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9542       real(kind=8) :: s1,s2,s3,s4
9543 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9544 !                                                                              C
9545 !      Parallel       Antiparallel                                             C
9546 !                                                                              C
9547 !          o             o                                                     C
9548 !         /l\   /   \   /j\                                                    C
9549 !        /   \ /     \ /   \                                                   C
9550 !       /| o |o       o| o |\                                                  C
9551 !       j|/k\|  /      |/k\|l /                                                C
9552 !        /   \ /       /   \ /                                                 C
9553 !       /     o       /     o                                                  C
9554 !       i             i                                                        C
9555 !                                                                              C
9556 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9557 !
9558 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9559 !           energy moment and not to the cluster cumulant.
9560       iti=itortyp(itype(i,1))
9561       if (j.lt.nres-1) then
9562         itj1=itortyp(itype(j+1,1))
9563       else
9564         itj1=ntortyp+1
9565       endif
9566       itk=itortyp(itype(k,1))
9567       itk1=itortyp(itype(k+1,1))
9568       if (l.lt.nres-1) then
9569         itl1=itortyp(itype(l+1,1))
9570       else
9571         itl1=ntortyp+1
9572       endif
9573 #ifdef MOMENT
9574       s1=dip(4,jj,i)*dip(4,kk,k)
9575 #endif
9576       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9577       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9578       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9579       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9580       call transpose2(EE(1,1,itk),auxmat(1,1))
9581       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9582       vv(1)=pizda(1,1)+pizda(2,2)
9583       vv(2)=pizda(2,1)-pizda(1,2)
9584       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9585 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9586 !d     & "sum",-(s2+s3+s4)
9587 #ifdef MOMENT
9588       eello6_graph3=-(s1+s2+s3+s4)
9589 #else
9590       eello6_graph3=-(s2+s3+s4)
9591 #endif
9592 !      eello6_graph3=-s4
9593 ! Derivatives in gamma(k-1)
9594       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9595       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9596       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9597       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9598 ! Derivatives in gamma(l-1)
9599       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9600       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9601       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9602       vv(1)=pizda(1,1)+pizda(2,2)
9603       vv(2)=pizda(2,1)-pizda(1,2)
9604       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9605       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9606 ! Cartesian derivatives.
9607       do iii=1,2
9608         do kkk=1,5
9609           do lll=1,3
9610 #ifdef MOMENT
9611             if (iii.eq.1) then
9612               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9613             else
9614               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9615             endif
9616 #endif
9617             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9618               auxvec(1))
9619             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9620             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9621               auxvec(1))
9622             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9623             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9624               pizda(1,1))
9625             vv(1)=pizda(1,1)+pizda(2,2)
9626             vv(2)=pizda(2,1)-pizda(1,2)
9627             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9628 #ifdef MOMENT
9629             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9630 #else
9631             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9632 #endif
9633             if (swap) then
9634               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9635             else
9636               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9637             endif
9638 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9639           enddo
9640         enddo
9641       enddo
9642       return
9643       end function eello6_graph3
9644 !-----------------------------------------------------------------------------
9645       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9646 !      implicit real*8 (a-h,o-z)
9647 !      include 'DIMENSIONS'
9648 !      include 'COMMON.IOUNITS'
9649 !      include 'COMMON.CHAIN'
9650 !      include 'COMMON.DERIV'
9651 !      include 'COMMON.INTERACT'
9652 !      include 'COMMON.CONTACTS'
9653 !      include 'COMMON.TORSION'
9654 !      include 'COMMON.VAR'
9655 !      include 'COMMON.GEO'
9656 !      include 'COMMON.FFIELD'
9657       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9658       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9659       logical :: swap
9660       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9661               iii,kkk,lll
9662       real(kind=8) :: s1,s2,s3,s4
9663 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9664 !                                                                              C
9665 !      Parallel       Antiparallel                                             C
9666 !                                                                              C
9667 !          o             o                                                     C
9668 !         /l\   /   \   /j\                                                    C
9669 !        /   \ /     \ /   \                                                   C
9670 !       /| o |o       o| o |\                                                  C
9671 !     \ j|/k\|      \  |/k\|l                                                  C
9672 !      \ /   \       \ /   \                                                   C
9673 !       o     \       o     \                                                  C
9674 !       i             i                                                        C
9675 !                                                                              C
9676 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9677 !
9678 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9679 !           energy moment and not to the cluster cumulant.
9680 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9681       iti=itortyp(itype(i,1))
9682       itj=itortyp(itype(j,1))
9683       if (j.lt.nres-1) then
9684         itj1=itortyp(itype(j+1,1))
9685       else
9686         itj1=ntortyp+1
9687       endif
9688       itk=itortyp(itype(k,1))
9689       if (k.lt.nres-1) then
9690         itk1=itortyp(itype(k+1,1))
9691       else
9692         itk1=ntortyp+1
9693       endif
9694       itl=itortyp(itype(l,1))
9695       if (l.lt.nres-1) then
9696         itl1=itortyp(itype(l+1,1))
9697       else
9698         itl1=ntortyp+1
9699       endif
9700 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9701 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9702 !d     & ' itl',itl,' itl1',itl1
9703 #ifdef MOMENT
9704       if (imat.eq.1) then
9705         s1=dip(3,jj,i)*dip(3,kk,k)
9706       else
9707         s1=dip(2,jj,j)*dip(2,kk,l)
9708       endif
9709 #endif
9710       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9711       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9712       if (j.eq.l+1) then
9713         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9714         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9715       else
9716         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9717         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9718       endif
9719       call transpose2(EUg(1,1,k),auxmat(1,1))
9720       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9721       vv(1)=pizda(1,1)-pizda(2,2)
9722       vv(2)=pizda(2,1)+pizda(1,2)
9723       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9724 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9725 #ifdef MOMENT
9726       eello6_graph4=-(s1+s2+s3+s4)
9727 #else
9728       eello6_graph4=-(s2+s3+s4)
9729 #endif
9730 ! Derivatives in gamma(i-1)
9731       if (i.gt.1) then
9732 #ifdef MOMENT
9733         if (imat.eq.1) then
9734           s1=dipderg(2,jj,i)*dip(3,kk,k)
9735         else
9736           s1=dipderg(4,jj,j)*dip(2,kk,l)
9737         endif
9738 #endif
9739         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9740         if (j.eq.l+1) then
9741           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9742           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9743         else
9744           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9745           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9746         endif
9747         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9748         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9749 !d          write (2,*) 'turn6 derivatives'
9750 #ifdef MOMENT
9751           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9752 #else
9753           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9754 #endif
9755         else
9756 #ifdef MOMENT
9757           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9758 #else
9759           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9760 #endif
9761         endif
9762       endif
9763 ! Derivatives in gamma(k-1)
9764 #ifdef MOMENT
9765       if (imat.eq.1) then
9766         s1=dip(3,jj,i)*dipderg(2,kk,k)
9767       else
9768         s1=dip(2,jj,j)*dipderg(4,kk,l)
9769       endif
9770 #endif
9771       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9772       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9773       if (j.eq.l+1) then
9774         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9775         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9776       else
9777         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9778         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9779       endif
9780       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9781       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9782       vv(1)=pizda(1,1)-pizda(2,2)
9783       vv(2)=pizda(2,1)+pizda(1,2)
9784       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9785       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9786 #ifdef MOMENT
9787         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9788 #else
9789         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9790 #endif
9791       else
9792 #ifdef MOMENT
9793         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9794 #else
9795         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9796 #endif
9797       endif
9798 ! Derivatives in gamma(j-1) or gamma(l-1)
9799       if (l.eq.j+1 .and. l.gt.1) then
9800         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9801         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9802         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9803         vv(1)=pizda(1,1)-pizda(2,2)
9804         vv(2)=pizda(2,1)+pizda(1,2)
9805         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9806         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9807       else if (j.gt.1) then
9808         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9809         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9810         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9811         vv(1)=pizda(1,1)-pizda(2,2)
9812         vv(2)=pizda(2,1)+pizda(1,2)
9813         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9814         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9815           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9816         else
9817           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9818         endif
9819       endif
9820 ! Cartesian derivatives.
9821       do iii=1,2
9822         do kkk=1,5
9823           do lll=1,3
9824 #ifdef MOMENT
9825             if (iii.eq.1) then
9826               if (imat.eq.1) then
9827                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9828               else
9829                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9830               endif
9831             else
9832               if (imat.eq.1) then
9833                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9834               else
9835                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9836               endif
9837             endif
9838 #endif
9839             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9840               auxvec(1))
9841             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9842             if (j.eq.l+1) then
9843               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9844                 b1(1,itj1),auxvec(1))
9845               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9846             else
9847               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9848                 b1(1,itl1),auxvec(1))
9849               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9850             endif
9851             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9852               pizda(1,1))
9853             vv(1)=pizda(1,1)-pizda(2,2)
9854             vv(2)=pizda(2,1)+pizda(1,2)
9855             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9856             if (swap) then
9857               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9858 #ifdef MOMENT
9859                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9860                    -(s1+s2+s4)
9861 #else
9862                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9863                    -(s2+s4)
9864 #endif
9865                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9866               else
9867 #ifdef MOMENT
9868                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9869 #else
9870                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9871 #endif
9872                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9873               endif
9874             else
9875 #ifdef MOMENT
9876               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9877 #else
9878               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9879 #endif
9880               if (l.eq.j+1) then
9881                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9882               else
9883                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9884               endif
9885             endif
9886           enddo
9887         enddo
9888       enddo
9889       return
9890       end function eello6_graph4
9891 !-----------------------------------------------------------------------------
9892       real(kind=8) function eello_turn6(i,jj,kk)
9893 !      implicit real*8 (a-h,o-z)
9894 !      include 'DIMENSIONS'
9895 !      include 'COMMON.IOUNITS'
9896 !      include 'COMMON.CHAIN'
9897 !      include 'COMMON.DERIV'
9898 !      include 'COMMON.INTERACT'
9899 !      include 'COMMON.CONTACTS'
9900 !      include 'COMMON.TORSION'
9901 !      include 'COMMON.VAR'
9902 !      include 'COMMON.GEO'
9903       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9904       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9905       real(kind=8),dimension(3) :: ggg1,ggg2
9906       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9907       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9908 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9909 !           the respective energy moment and not to the cluster cumulant.
9910 !el local variables
9911       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9912       integer :: j1,j2,l1,l2,ll
9913       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9914       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9915       s1=0.0d0
9916       s8=0.0d0
9917       s13=0.0d0
9918 !
9919       eello_turn6=0.0d0
9920       j=i+4
9921       k=i+1
9922       l=i+3
9923       iti=itortyp(itype(i,1))
9924       itk=itortyp(itype(k,1))
9925       itk1=itortyp(itype(k+1,1))
9926       itl=itortyp(itype(l,1))
9927       itj=itortyp(itype(j,1))
9928 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9929 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
9930 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9931 !d        eello6=0.0d0
9932 !d        return
9933 !d      endif
9934 !d      write (iout,*)
9935 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9936 !d     &   ' and',k,l
9937 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
9938       do iii=1,2
9939         do kkk=1,5
9940           do lll=1,3
9941             derx_turn(lll,kkk,iii)=0.0d0
9942           enddo
9943         enddo
9944       enddo
9945 !d      eij=1.0d0
9946 !d      ekl=1.0d0
9947 !d      ekont=1.0d0
9948       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9949 !d      eello6_5=0.0d0
9950 !d      write (2,*) 'eello6_5',eello6_5
9951 #ifdef MOMENT
9952       call transpose2(AEA(1,1,1),auxmat(1,1))
9953       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9954       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9955       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9956 #endif
9957       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9958       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9959       s2 = scalar2(b1(1,itk),vtemp1(1))
9960 #ifdef MOMENT
9961       call transpose2(AEA(1,1,2),atemp(1,1))
9962       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9963       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9964       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9965 #endif
9966       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9967       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9968       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9969 #ifdef MOMENT
9970       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9971       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9972       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9973       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9974       ss13 = scalar2(b1(1,itk),vtemp4(1))
9975       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9976 #endif
9977 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9978 !      s1=0.0d0
9979 !      s2=0.0d0
9980 !      s8=0.0d0
9981 !      s12=0.0d0
9982 !      s13=0.0d0
9983       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9984 ! Derivatives in gamma(i+2)
9985       s1d =0.0d0
9986       s8d =0.0d0
9987 #ifdef MOMENT
9988       call transpose2(AEA(1,1,1),auxmatd(1,1))
9989       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9990       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9991       call transpose2(AEAderg(1,1,2),atempd(1,1))
9992       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9993       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9994 #endif
9995       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9996       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9997       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9998 !      s1d=0.0d0
9999 !      s2d=0.0d0
10000 !      s8d=0.0d0
10001 !      s12d=0.0d0
10002 !      s13d=0.0d0
10003       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10004 ! Derivatives in gamma(i+3)
10005 #ifdef MOMENT
10006       call transpose2(AEA(1,1,1),auxmatd(1,1))
10007       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10008       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10009       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10010 #endif
10011       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10012       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10013       s2d = scalar2(b1(1,itk),vtemp1d(1))
10014 #ifdef MOMENT
10015       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10016       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10017 #endif
10018       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10019 #ifdef MOMENT
10020       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10021       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10022       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10023 #endif
10024 !      s1d=0.0d0
10025 !      s2d=0.0d0
10026 !      s8d=0.0d0
10027 !      s12d=0.0d0
10028 !      s13d=0.0d0
10029 #ifdef MOMENT
10030       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10031                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10032 #else
10033       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10034                     -0.5d0*ekont*(s2d+s12d)
10035 #endif
10036 ! Derivatives in gamma(i+4)
10037       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10038       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10039       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10040 #ifdef MOMENT
10041       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10042       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10043       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10044 #endif
10045 !      s1d=0.0d0
10046 !      s2d=0.0d0
10047 !      s8d=0.0d0
10048 !      s12d=0.0d0
10049 !      s13d=0.0d0
10050 #ifdef MOMENT
10051       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10052 #else
10053       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10054 #endif
10055 ! Derivatives in gamma(i+5)
10056 #ifdef MOMENT
10057       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10058       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10059       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10060 #endif
10061       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10062       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10063       s2d = scalar2(b1(1,itk),vtemp1d(1))
10064 #ifdef MOMENT
10065       call transpose2(AEA(1,1,2),atempd(1,1))
10066       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10067       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10068 #endif
10069       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10070       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10071 #ifdef MOMENT
10072       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10073       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10074       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10075 #endif
10076 !      s1d=0.0d0
10077 !      s2d=0.0d0
10078 !      s8d=0.0d0
10079 !      s12d=0.0d0
10080 !      s13d=0.0d0
10081 #ifdef MOMENT
10082       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10083                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10084 #else
10085       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10086                     -0.5d0*ekont*(s2d+s12d)
10087 #endif
10088 ! Cartesian derivatives
10089       do iii=1,2
10090         do kkk=1,5
10091           do lll=1,3
10092 #ifdef MOMENT
10093             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10094             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10095             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10096 #endif
10097             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10098             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10099                 vtemp1d(1))
10100             s2d = scalar2(b1(1,itk),vtemp1d(1))
10101 #ifdef MOMENT
10102             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10103             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10104             s8d = -(atempd(1,1)+atempd(2,2))* &
10105                  scalar2(cc(1,1,itl),vtemp2(1))
10106 #endif
10107             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10108                  auxmatd(1,1))
10109             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10110             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10111 !      s1d=0.0d0
10112 !      s2d=0.0d0
10113 !      s8d=0.0d0
10114 !      s12d=0.0d0
10115 !      s13d=0.0d0
10116 #ifdef MOMENT
10117             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10118               - 0.5d0*(s1d+s2d)
10119 #else
10120             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10121               - 0.5d0*s2d
10122 #endif
10123 #ifdef MOMENT
10124             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10125               - 0.5d0*(s8d+s12d)
10126 #else
10127             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10128               - 0.5d0*s12d
10129 #endif
10130           enddo
10131         enddo
10132       enddo
10133 #ifdef MOMENT
10134       do kkk=1,5
10135         do lll=1,3
10136           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10137             achuj_tempd(1,1))
10138           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10139           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10140           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10141           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10142           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10143             vtemp4d(1))
10144           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10145           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10146           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10147         enddo
10148       enddo
10149 #endif
10150 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10151 !d     &  16*eel_turn6_num
10152 !d      goto 1112
10153       if (j.lt.nres-1) then
10154         j1=j+1
10155         j2=j-1
10156       else
10157         j1=j-1
10158         j2=j-2
10159       endif
10160       if (l.lt.nres-1) then
10161         l1=l+1
10162         l2=l-1
10163       else
10164         l1=l-1
10165         l2=l-2
10166       endif
10167       do ll=1,3
10168 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10169 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10170 !grad        ghalf=0.5d0*ggg1(ll)
10171 !d        ghalf=0.0d0
10172         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10173         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10174         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10175           +ekont*derx_turn(ll,2,1)
10176         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10177         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10178           +ekont*derx_turn(ll,4,1)
10179         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10180         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10181         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10182 !grad        ghalf=0.5d0*ggg2(ll)
10183 !d        ghalf=0.0d0
10184         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10185           +ekont*derx_turn(ll,2,2)
10186         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10187         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10188           +ekont*derx_turn(ll,4,2)
10189         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10190         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10191         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10192       enddo
10193 !d      goto 1112
10194 !grad      do m=i+1,j-1
10195 !grad        do ll=1,3
10196 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10197 !grad        enddo
10198 !grad      enddo
10199 !grad      do m=k+1,l-1
10200 !grad        do ll=1,3
10201 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10202 !grad        enddo
10203 !grad      enddo
10204 !grad1112  continue
10205 !grad      do m=i+2,j2
10206 !grad        do ll=1,3
10207 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10208 !grad        enddo
10209 !grad      enddo
10210 !grad      do m=k+2,l2
10211 !grad        do ll=1,3
10212 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10213 !grad        enddo
10214 !grad      enddo
10215 !d      do iii=1,nres-3
10216 !d        write (2,*) iii,g_corr6_loc(iii)
10217 !d      enddo
10218       eello_turn6=ekont*eel_turn6
10219 !d      write (2,*) 'ekont',ekont
10220 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10221       return
10222       end function eello_turn6
10223 !-----------------------------------------------------------------------------
10224       subroutine MATVEC2(A1,V1,V2)
10225 !DIR$ INLINEALWAYS MATVEC2
10226 #ifndef OSF
10227 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10228 #endif
10229 !      implicit real*8 (a-h,o-z)
10230 !      include 'DIMENSIONS'
10231       real(kind=8),dimension(2) :: V1,V2
10232       real(kind=8),dimension(2,2) :: A1
10233       real(kind=8) :: vaux1,vaux2
10234 !      DO 1 I=1,2
10235 !        VI=0.0
10236 !        DO 3 K=1,2
10237 !    3     VI=VI+A1(I,K)*V1(K)
10238 !        Vaux(I)=VI
10239 !    1 CONTINUE
10240
10241       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10242       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10243
10244       v2(1)=vaux1
10245       v2(2)=vaux2
10246       end subroutine MATVEC2
10247 !-----------------------------------------------------------------------------
10248       subroutine MATMAT2(A1,A2,A3)
10249 #ifndef OSF
10250 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10251 #endif
10252 !      implicit real*8 (a-h,o-z)
10253 !      include 'DIMENSIONS'
10254       real(kind=8),dimension(2,2) :: A1,A2,A3
10255       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10256 !      DIMENSION AI3(2,2)
10257 !        DO  J=1,2
10258 !          A3IJ=0.0
10259 !          DO K=1,2
10260 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10261 !          enddo
10262 !          A3(I,J)=A3IJ
10263 !       enddo
10264 !      enddo
10265
10266       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10267       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10268       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10269       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10270
10271       A3(1,1)=AI3_11
10272       A3(2,1)=AI3_21
10273       A3(1,2)=AI3_12
10274       A3(2,2)=AI3_22
10275       end subroutine MATMAT2
10276 !-----------------------------------------------------------------------------
10277       real(kind=8) function scalar2(u,v)
10278 !DIR$ INLINEALWAYS scalar2
10279       implicit none
10280       real(kind=8),dimension(2) :: u,v
10281       real(kind=8) :: sc
10282       integer :: i
10283       scalar2=u(1)*v(1)+u(2)*v(2)
10284       return
10285       end function scalar2
10286 !-----------------------------------------------------------------------------
10287       subroutine transpose2(a,at)
10288 !DIR$ INLINEALWAYS transpose2
10289 #ifndef OSF
10290 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10291 #endif
10292       implicit none
10293       real(kind=8),dimension(2,2) :: a,at
10294       at(1,1)=a(1,1)
10295       at(1,2)=a(2,1)
10296       at(2,1)=a(1,2)
10297       at(2,2)=a(2,2)
10298       return
10299       end subroutine transpose2
10300 !-----------------------------------------------------------------------------
10301       subroutine transpose(n,a,at)
10302       implicit none
10303       integer :: n,i,j
10304       real(kind=8),dimension(n,n) :: a,at
10305       do i=1,n
10306         do j=1,n
10307           at(j,i)=a(i,j)
10308         enddo
10309       enddo
10310       return
10311       end subroutine transpose
10312 !-----------------------------------------------------------------------------
10313       subroutine prodmat3(a1,a2,kk,transp,prod)
10314 !DIR$ INLINEALWAYS prodmat3
10315 #ifndef OSF
10316 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10317 #endif
10318       implicit none
10319       integer :: i,j
10320       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10321       logical :: transp
10322 !rc      double precision auxmat(2,2),prod_(2,2)
10323
10324       if (transp) then
10325 !rc        call transpose2(kk(1,1),auxmat(1,1))
10326 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10327 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10328
10329            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10330        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10331            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10332        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10333            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10334        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10335            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10336        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10337
10338       else
10339 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10340 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10341
10342            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10343         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10344            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10345         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10346            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10347         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10348            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10349         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10350
10351       endif
10352 !      call transpose2(a2(1,1),a2t(1,1))
10353
10354 !rc      print *,transp
10355 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10356 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10357
10358       return
10359       end subroutine prodmat3
10360 !-----------------------------------------------------------------------------
10361 ! energy_p_new_barrier.F
10362 !-----------------------------------------------------------------------------
10363       subroutine sum_gradient
10364 !      implicit real*8 (a-h,o-z)
10365       use io_base, only: pdbout
10366 !      include 'DIMENSIONS'
10367 #ifndef ISNAN
10368       external proc_proc
10369 #ifdef WINPGI
10370 !MS$ATTRIBUTES C ::  proc_proc
10371 #endif
10372 #endif
10373 #ifdef MPI
10374       include 'mpif.h'
10375 #endif
10376       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10377                    gloc_scbuf !(3,maxres)
10378
10379       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10380 !#endif
10381 !el local variables
10382       integer :: i,j,k,ierror,ierr
10383       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10384                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10385                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10386                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10387                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10388                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10389                    gsccorr_max,gsccorrx_max,time00
10390
10391 !      include 'COMMON.SETUP'
10392 !      include 'COMMON.IOUNITS'
10393 !      include 'COMMON.FFIELD'
10394 !      include 'COMMON.DERIV'
10395 !      include 'COMMON.INTERACT'
10396 !      include 'COMMON.SBRIDGE'
10397 !      include 'COMMON.CHAIN'
10398 !      include 'COMMON.VAR'
10399 !      include 'COMMON.CONTROL'
10400 !      include 'COMMON.TIME1'
10401 !      include 'COMMON.MAXGRAD'
10402 !      include 'COMMON.SCCOR'
10403 #ifdef TIMING
10404       time01=MPI_Wtime()
10405 #endif
10406 #ifdef DEBUG
10407       write (iout,*) "sum_gradient gvdwc, gvdwx"
10408       do i=1,nres
10409         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10410          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10411       enddo
10412       call flush(iout)
10413 #endif
10414 #ifdef MPI
10415         gradbufc=0.0d0
10416         gradbufx=0.0d0
10417         gradbufc_sum=0.0d0
10418         gloc_scbuf=0.0d0
10419         glocbuf=0.0d0
10420 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10421         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10422           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10423 #endif
10424 !
10425 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10426 !            in virtual-bond-vector coordinates
10427 !
10428 #ifdef DEBUG
10429 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10430 !      do i=1,nres-1
10431 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10432 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10433 !      enddo
10434 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10435 !      do i=1,nres-1
10436 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10437 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10438 !      enddo
10439       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10440       do i=1,nres
10441         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10442          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10443          (gvdwc_scpp(j,i),j=1,3)
10444       enddo
10445       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10446       do i=1,nres
10447         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10448          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10449          (gelc_loc_long(j,i),j=1,3)
10450       enddo
10451       call flush(iout)
10452 #endif
10453 #ifdef SPLITELE
10454       do i=0,nct
10455         do j=1,3
10456           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10457                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10458                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10459                       wel_loc*gel_loc_long(j,i)+ &
10460                       wcorr*gradcorr_long(j,i)+ &
10461                       wcorr5*gradcorr5_long(j,i)+ &
10462                       wcorr6*gradcorr6_long(j,i)+ &
10463                       wturn6*gcorr6_turn_long(j,i)+ &
10464                       wstrain*ghpbc(j,i) &
10465                      +wliptran*gliptranc(j,i) &
10466                      +gradafm(j,i) &
10467                      +welec*gshieldc(j,i) &
10468                      +wcorr*gshieldc_ec(j,i) &
10469                      +wturn3*gshieldc_t3(j,i)&
10470                      +wturn4*gshieldc_t4(j,i)&
10471                      +wel_loc*gshieldc_ll(j,i)&
10472                      +wtube*gg_tube(j,i) &
10473                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10474                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10475                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10476                      wcorr_nucl*gradcorr_nucl(j,i)&
10477                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
10478                      wcatprot* gradpepcat(j,i)+ &
10479                      wcatcat*gradcatcat(j,i)
10480
10481
10482         enddo
10483       enddo
10484 #else
10485       do i=0,nct
10486         do j=1,3
10487           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10488                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10489                       welec*gelc_long(j,i)+ &
10490                       wbond*gradb(j,i)+ &
10491                       wel_loc*gel_loc_long(j,i)+ &
10492                       wcorr*gradcorr_long(j,i)+ &
10493                       wcorr5*gradcorr5_long(j,i)+ &
10494                       wcorr6*gradcorr6_long(j,i)+ &
10495                       wturn6*gcorr6_turn_long(j,i)+ &
10496                       wstrain*ghpbc(j,i) &
10497                      +wliptran*gliptranc(j,i) &
10498                      +gradafm(j,i) &
10499                      +welec*gshieldc(j,i)&
10500                      +wcorr*gshieldc_ec(j,i) &
10501                      +wturn4*gshieldc_t4(j,i) &
10502                      +wel_loc*gshieldc_ll(j,i)&
10503                      +wtube*gg_tube(j,i) &
10504                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10505                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10506                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10507                      wcorr_nucl*gradcorr_nucl(j,i) &
10508                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
10509                      wcatprot* gradpepcat(j,i)+ &
10510                      wcatcat*gradcatcat(j,i)
10511         enddo
10512       enddo
10513 #endif
10514 #ifdef MPI
10515       if (nfgtasks.gt.1) then
10516       time00=MPI_Wtime()
10517 #ifdef DEBUG
10518       write (iout,*) "gradbufc before allreduce"
10519       do i=1,nres
10520         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10521       enddo
10522       call flush(iout)
10523 #endif
10524       do i=0,nres
10525         do j=1,3
10526           gradbufc_sum(j,i)=gradbufc(j,i)
10527         enddo
10528       enddo
10529 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10530 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10531 !      time_reduce=time_reduce+MPI_Wtime()-time00
10532 #ifdef DEBUG
10533 !      write (iout,*) "gradbufc_sum after allreduce"
10534 !      do i=1,nres
10535 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10536 !      enddo
10537 !      call flush(iout)
10538 #endif
10539 #ifdef TIMING
10540 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10541 #endif
10542       do i=0,nres
10543         do k=1,3
10544           gradbufc(k,i)=0.0d0
10545         enddo
10546       enddo
10547 #ifdef DEBUG
10548       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10549       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10550                         " jgrad_end  ",jgrad_end(i),&
10551                         i=igrad_start,igrad_end)
10552 #endif
10553 !
10554 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10555 ! do not parallelize this part.
10556 !
10557 !      do i=igrad_start,igrad_end
10558 !        do j=jgrad_start(i),jgrad_end(i)
10559 !          do k=1,3
10560 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10561 !          enddo
10562 !        enddo
10563 !      enddo
10564       do j=1,3
10565         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10566       enddo
10567       do i=nres-2,-1,-1
10568         do j=1,3
10569           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10570         enddo
10571       enddo
10572 #ifdef DEBUG
10573       write (iout,*) "gradbufc after summing"
10574       do i=1,nres
10575         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10576       enddo
10577       call flush(iout)
10578 #endif
10579       else
10580 #endif
10581 !el#define DEBUG
10582 #ifdef DEBUG
10583       write (iout,*) "gradbufc"
10584       do i=1,nres
10585         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10586       enddo
10587       call flush(iout)
10588 #endif
10589 !el#undef DEBUG
10590       do i=-1,nres
10591         do j=1,3
10592           gradbufc_sum(j,i)=gradbufc(j,i)
10593           gradbufc(j,i)=0.0d0
10594         enddo
10595       enddo
10596       do j=1,3
10597         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10598       enddo
10599       do i=nres-2,-1,-1
10600         do j=1,3
10601           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10602         enddo
10603       enddo
10604 !      do i=nnt,nres-1
10605 !        do k=1,3
10606 !          gradbufc(k,i)=0.0d0
10607 !        enddo
10608 !        do j=i+1,nres
10609 !          do k=1,3
10610 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10611 !          enddo
10612 !        enddo
10613 !      enddo
10614 !el#define DEBUG
10615 #ifdef DEBUG
10616       write (iout,*) "gradbufc after summing"
10617       do i=1,nres
10618         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10619       enddo
10620       call flush(iout)
10621 #endif
10622 !el#undef DEBUG
10623 #ifdef MPI
10624       endif
10625 #endif
10626       do k=1,3
10627         gradbufc(k,nres)=0.0d0
10628       enddo
10629 !el----------------
10630 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10631 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10632 !el-----------------
10633       do i=-1,nct
10634         do j=1,3
10635 #ifdef SPLITELE
10636           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10637                       wel_loc*gel_loc(j,i)+ &
10638                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10639                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10640                       wel_loc*gel_loc_long(j,i)+ &
10641                       wcorr*gradcorr_long(j,i)+ &
10642                       wcorr5*gradcorr5_long(j,i)+ &
10643                       wcorr6*gradcorr6_long(j,i)+ &
10644                       wturn6*gcorr6_turn_long(j,i))+ &
10645                       wbond*gradb(j,i)+ &
10646                       wcorr*gradcorr(j,i)+ &
10647                       wturn3*gcorr3_turn(j,i)+ &
10648                       wturn4*gcorr4_turn(j,i)+ &
10649                       wcorr5*gradcorr5(j,i)+ &
10650                       wcorr6*gradcorr6(j,i)+ &
10651                       wturn6*gcorr6_turn(j,i)+ &
10652                       wsccor*gsccorc(j,i) &
10653                      +wscloc*gscloc(j,i)  &
10654                      +wliptran*gliptranc(j,i) &
10655                      +gradafm(j,i) &
10656                      +welec*gshieldc(j,i) &
10657                      +welec*gshieldc_loc(j,i) &
10658                      +wcorr*gshieldc_ec(j,i) &
10659                      +wcorr*gshieldc_loc_ec(j,i) &
10660                      +wturn3*gshieldc_t3(j,i) &
10661                      +wturn3*gshieldc_loc_t3(j,i) &
10662                      +wturn4*gshieldc_t4(j,i) &
10663                      +wturn4*gshieldc_loc_t4(j,i) &
10664                      +wel_loc*gshieldc_ll(j,i) &
10665                      +wel_loc*gshieldc_loc_ll(j,i) &
10666                      +wtube*gg_tube(j,i) &
10667                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10668                      +wvdwpsb*gvdwpsb1(j,i))&
10669                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
10670
10671 !                 if ((i.le.2).and.(i.ge.1))
10672 !                       print *,gradc(j,i,icg),&
10673 !                      gradbufc(j,i),welec*gelc(j,i), &
10674 !                      wel_loc*gel_loc(j,i), &
10675 !                      wscp*gvdwc_scpp(j,i), &
10676 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
10677 !                      wel_loc*gel_loc_long(j,i), &
10678 !                      wcorr*gradcorr_long(j,i), &
10679 !                      wcorr5*gradcorr5_long(j,i), &
10680 !                      wcorr6*gradcorr6_long(j,i), &
10681 !                      wturn6*gcorr6_turn_long(j,i), &
10682 !                      wbond*gradb(j,i), &
10683 !                      wcorr*gradcorr(j,i), &
10684 !                      wturn3*gcorr3_turn(j,i), &
10685 !                      wturn4*gcorr4_turn(j,i), &
10686 !                      wcorr5*gradcorr5(j,i), &
10687 !                      wcorr6*gradcorr6(j,i), &
10688 !                      wturn6*gcorr6_turn(j,i), &
10689 !                      wsccor*gsccorc(j,i) &
10690 !                     ,wscloc*gscloc(j,i)  &
10691 !                     ,wliptran*gliptranc(j,i) &
10692 !                    ,gradafm(j,i) &
10693 !                     ,welec*gshieldc(j,i) &
10694 !                     ,welec*gshieldc_loc(j,i) &
10695 !                     ,wcorr*gshieldc_ec(j,i) &
10696 !                     ,wcorr*gshieldc_loc_ec(j,i) &
10697 !                     ,wturn3*gshieldc_t3(j,i) &
10698 !                     ,wturn3*gshieldc_loc_t3(j,i) &
10699 !                     ,wturn4*gshieldc_t4(j,i) &
10700 !                     ,wturn4*gshieldc_loc_t4(j,i) &
10701 !                     ,wel_loc*gshieldc_ll(j,i) &
10702 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
10703 !                     ,wtube*gg_tube(j,i) &
10704 !                     ,wbond_nucl*gradb_nucl(j,i) &
10705 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
10706 !                     wvdwpsb*gvdwpsb1(j,i)&
10707 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
10708 !
10709
10710 #else
10711           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10712                       wel_loc*gel_loc(j,i)+ &
10713                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10714                       welec*gelc_long(j,i)+ &
10715                       wel_loc*gel_loc_long(j,i)+ &
10716 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10717                       wcorr5*gradcorr5_long(j,i)+ &
10718                       wcorr6*gradcorr6_long(j,i)+ &
10719                       wturn6*gcorr6_turn_long(j,i))+ &
10720                       wbond*gradb(j,i)+ &
10721                       wcorr*gradcorr(j,i)+ &
10722                       wturn3*gcorr3_turn(j,i)+ &
10723                       wturn4*gcorr4_turn(j,i)+ &
10724                       wcorr5*gradcorr5(j,i)+ &
10725                       wcorr6*gradcorr6(j,i)+ &
10726                       wturn6*gcorr6_turn(j,i)+ &
10727                       wsccor*gsccorc(j,i) &
10728                      +wscloc*gscloc(j,i) &
10729                      +gradafm(j,i) &
10730                      +wliptran*gliptranc(j,i) &
10731                      +welec*gshieldc(j,i) &
10732                      +welec*gshieldc_loc(j,) &
10733                      +wcorr*gshieldc_ec(j,i) &
10734                      +wcorr*gshieldc_loc_ec(j,i) &
10735                      +wturn3*gshieldc_t3(j,i) &
10736                      +wturn3*gshieldc_loc_t3(j,i) &
10737                      +wturn4*gshieldc_t4(j,i) &
10738                      +wturn4*gshieldc_loc_t4(j,i) &
10739                      +wel_loc*gshieldc_ll(j,i) &
10740                      +wel_loc*gshieldc_loc_ll(j,i) &
10741                      +wtube*gg_tube(j,i) &
10742                      +wbond_nucl*gradb_nucl(j,i) &
10743                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10744                      +wvdwpsb*gvdwpsb1(j,i))&
10745                      +wsbloc*gsbloc(j,i)
10746
10747
10748
10749
10750 #endif
10751           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10752                         wbond*gradbx(j,i)+ &
10753                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10754                         wsccor*gsccorx(j,i) &
10755                        +wscloc*gsclocx(j,i) &
10756                        +wliptran*gliptranx(j,i) &
10757                        +welec*gshieldx(j,i)     &
10758                        +wcorr*gshieldx_ec(j,i)  &
10759                        +wturn3*gshieldx_t3(j,i) &
10760                        +wturn4*gshieldx_t4(j,i) &
10761                        +wel_loc*gshieldx_ll(j,i)&
10762                        +wtube*gg_tube_sc(j,i)   &
10763                        +wbond_nucl*gradbx_nucl(j,i) &
10764                        +wvdwsb*gvdwsbx(j,i) &
10765                        +welsb*gelsbx(j,i) &
10766                        +wcorr_nucl*gradxorr_nucl(j,i)&
10767                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
10768                        +wsbloc*gsblocx(j,i) &
10769                        +wcatprot* gradpepcatx(j,i)
10770         enddo
10771       enddo
10772 #ifdef DEBUG
10773       write (iout,*) "gloc before adding corr"
10774       do i=1,4*nres
10775         write (iout,*) i,gloc(i,icg)
10776       enddo
10777 #endif
10778       do i=1,nres-3
10779         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10780          +wcorr5*g_corr5_loc(i) &
10781          +wcorr6*g_corr6_loc(i) &
10782          +wturn4*gel_loc_turn4(i) &
10783          +wturn3*gel_loc_turn3(i) &
10784          +wturn6*gel_loc_turn6(i) &
10785          +wel_loc*gel_loc_loc(i)
10786       enddo
10787 #ifdef DEBUG
10788       write (iout,*) "gloc after adding corr"
10789       do i=1,4*nres
10790         write (iout,*) i,gloc(i,icg)
10791       enddo
10792 #endif
10793 #ifdef MPI
10794       if (nfgtasks.gt.1) then
10795         do j=1,3
10796           do i=0,nres
10797             gradbufc(j,i)=gradc(j,i,icg)
10798             gradbufx(j,i)=gradx(j,i,icg)
10799           enddo
10800         enddo
10801         do i=1,4*nres
10802           glocbuf(i)=gloc(i,icg)
10803         enddo
10804 !#define DEBUG
10805 #ifdef DEBUG
10806       write (iout,*) "gloc_sc before reduce"
10807       do i=1,nres
10808        do j=1,1
10809         write (iout,*) i,j,gloc_sc(j,i,icg)
10810        enddo
10811       enddo
10812 #endif
10813 !#undef DEBUG
10814         do i=1,nres
10815          do j=1,3
10816           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10817          enddo
10818         enddo
10819         time00=MPI_Wtime()
10820         call MPI_Barrier(FG_COMM,IERR)
10821         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10822         time00=MPI_Wtime()
10823         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10824           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10825         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
10826           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10827         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10828           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10829         time_reduce=time_reduce+MPI_Wtime()-time00
10830         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10831           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10832         time_reduce=time_reduce+MPI_Wtime()-time00
10833 !#define DEBUG
10834 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
10835 #ifdef DEBUG
10836       write (iout,*) "gloc_sc after reduce"
10837       do i=1,nres
10838        do j=1,1
10839         write (iout,*) i,j,gloc_sc(j,i,icg)
10840        enddo
10841       enddo
10842 #endif
10843 !#undef DEBUG
10844 #ifdef DEBUG
10845       write (iout,*) "gloc after reduce"
10846       do i=1,4*nres
10847         write (iout,*) i,gloc(i,icg)
10848       enddo
10849 #endif
10850       endif
10851 #endif
10852       if (gnorm_check) then
10853 !
10854 ! Compute the maximum elements of the gradient
10855 !
10856       gvdwc_max=0.0d0
10857       gvdwc_scp_max=0.0d0
10858       gelc_max=0.0d0
10859       gvdwpp_max=0.0d0
10860       gradb_max=0.0d0
10861       ghpbc_max=0.0d0
10862       gradcorr_max=0.0d0
10863       gel_loc_max=0.0d0
10864       gcorr3_turn_max=0.0d0
10865       gcorr4_turn_max=0.0d0
10866       gradcorr5_max=0.0d0
10867       gradcorr6_max=0.0d0
10868       gcorr6_turn_max=0.0d0
10869       gsccorc_max=0.0d0
10870       gscloc_max=0.0d0
10871       gvdwx_max=0.0d0
10872       gradx_scp_max=0.0d0
10873       ghpbx_max=0.0d0
10874       gradxorr_max=0.0d0
10875       gsccorx_max=0.0d0
10876       gsclocx_max=0.0d0
10877       do i=1,nct
10878         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10879         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10880         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10881         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10882          gvdwc_scp_max=gvdwc_scp_norm
10883         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10884         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10885         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10886         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10887         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10888         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10889         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10890         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10891         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10892         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10893         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10894         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10895         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10896           gcorr3_turn(1,i)))
10897         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10898           gcorr3_turn_max=gcorr3_turn_norm
10899         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10900           gcorr4_turn(1,i)))
10901         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10902           gcorr4_turn_max=gcorr4_turn_norm
10903         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10904         if (gradcorr5_norm.gt.gradcorr5_max) &
10905           gradcorr5_max=gradcorr5_norm
10906         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10907         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10908         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10909           gcorr6_turn(1,i)))
10910         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10911           gcorr6_turn_max=gcorr6_turn_norm
10912         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
10913         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
10914         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
10915         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
10916         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
10917         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
10918         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
10919         if (gradx_scp_norm.gt.gradx_scp_max) &
10920           gradx_scp_max=gradx_scp_norm
10921         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
10922         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
10923         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
10924         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
10925         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
10926         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
10927         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
10928         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
10929       enddo
10930       if (gradout) then
10931 #ifdef AIX
10932         open(istat,file=statname,position="append")
10933 #else
10934         open(istat,file=statname,access="append")
10935 #endif
10936         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
10937            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
10938            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
10939            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
10940            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
10941            gsccorx_max,gsclocx_max
10942         close(istat)
10943         if (gvdwc_max.gt.1.0d4) then
10944           write (iout,*) "gvdwc gvdwx gradb gradbx"
10945           do i=nnt,nct
10946             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
10947               gradb(j,i),gradbx(j,i),j=1,3)
10948           enddo
10949           call pdbout(0.0d0,'cipiszcze',iout)
10950           call flush(iout)
10951         endif
10952       endif
10953       endif
10954 !el#define DEBUG
10955 #ifdef DEBUG
10956       write (iout,*) "gradc gradx gloc"
10957       do i=1,nres
10958         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
10959          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
10960       enddo
10961 #endif
10962 !el#undef DEBUG
10963 #ifdef TIMING
10964       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
10965 #endif
10966       return
10967       end subroutine sum_gradient
10968 !-----------------------------------------------------------------------------
10969       subroutine sc_grad
10970 !      implicit real*8 (a-h,o-z)
10971       use calc_data
10972 !      include 'DIMENSIONS'
10973 !      include 'COMMON.CHAIN'
10974 !      include 'COMMON.DERIV'
10975 !      include 'COMMON.CALC'
10976 !      include 'COMMON.IOUNITS'
10977       real(kind=8), dimension(3) :: dcosom1,dcosom2
10978 !      print *,"wchodze"
10979       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
10980       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
10981       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
10982            -2.0D0*alf12*eps3der+sigder*sigsq_om12
10983 ! diagnostics only
10984 !      eom1=0.0d0
10985 !      eom2=0.0d0
10986 !      eom12=evdwij*eps1_om12
10987 ! end diagnostics
10988 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
10989 !       " sigder",sigder
10990 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
10991 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
10992 !C      print *,sss_ele_cut,'in sc_grad'
10993       do k=1,3
10994         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
10995         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
10996       enddo
10997       do k=1,3
10998         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
10999 !C      print *,'gg',k,gg(k)
11000        enddo
11001 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11002 !      write (iout,*) "gg",(gg(k),k=1,3)
11003       do k=1,3
11004         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11005                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11006                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11007                   *sss_ele_cut
11008
11009         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11010                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11011                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11012                   *sss_ele_cut
11013
11014 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11015 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11016 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11017 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11018       enddo
11019 !
11020 ! Calculate the components of the gradient in DC and X
11021 !
11022 !grad      do k=i,j-1
11023 !grad        do l=1,3
11024 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11025 !grad        enddo
11026 !grad      enddo
11027       do l=1,3
11028         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11029         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11030       enddo
11031       return
11032       end subroutine sc_grad
11033 #ifdef CRYST_THETA
11034 !-----------------------------------------------------------------------------
11035       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11036
11037       use comm_calcthet
11038 !      implicit real*8 (a-h,o-z)
11039 !      include 'DIMENSIONS'
11040 !      include 'COMMON.LOCAL'
11041 !      include 'COMMON.IOUNITS'
11042 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11043 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11044 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11045       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11046       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11047 !el      integer :: it
11048 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11049 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11050 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11051 !el local variables
11052
11053       delthec=thetai-thet_pred_mean
11054       delthe0=thetai-theta0i
11055 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11056       t3 = thetai-thet_pred_mean
11057       t6 = t3**2
11058       t9 = term1
11059       t12 = t3*sigcsq
11060       t14 = t12+t6*sigsqtc
11061       t16 = 1.0d0
11062       t21 = thetai-theta0i
11063       t23 = t21**2
11064       t26 = term2
11065       t27 = t21*t26
11066       t32 = termexp
11067       t40 = t32**2
11068       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11069        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11070        *(-t12*t9-ak*sig0inv*t27)
11071       return
11072       end subroutine mixder
11073 #endif
11074 !-----------------------------------------------------------------------------
11075 ! cartder.F
11076 !-----------------------------------------------------------------------------
11077       subroutine cartder
11078 !-----------------------------------------------------------------------------
11079 ! This subroutine calculates the derivatives of the consecutive virtual
11080 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11081 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11082 ! in the angles alpha and omega, describing the location of a side chain
11083 ! in its local coordinate system.
11084 !
11085 ! The derivatives are stored in the following arrays:
11086 !
11087 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11088 ! The structure is as follows:
11089 !
11090 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11091 ! 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)
11092 !         . . . . . . . . . . . .  . . . . . .
11093 ! 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)
11094 !                          .
11095 !                          .
11096 !                          .
11097 ! 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)
11098 !
11099 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11100 ! The structure is same as above.
11101 !
11102 ! DCDS - the derivatives of the side chain vectors in the local spherical
11103 ! andgles alph and omega:
11104 !
11105 ! 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)
11106 ! 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)
11107 !                          .
11108 !                          .
11109 !                          .
11110 ! 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)
11111 !
11112 ! Version of March '95, based on an early version of November '91.
11113 !
11114 !**********************************************************************
11115 !      implicit real*8 (a-h,o-z)
11116 !      include 'DIMENSIONS'
11117 !      include 'COMMON.VAR'
11118 !      include 'COMMON.CHAIN'
11119 !      include 'COMMON.DERIV'
11120 !      include 'COMMON.GEO'
11121 !      include 'COMMON.LOCAL'
11122 !      include 'COMMON.INTERACT'
11123       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11124       real(kind=8),dimension(3,3) :: dp,temp
11125 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11126       real(kind=8),dimension(3) :: xx,xx1
11127 !el local variables
11128       integer :: i,k,l,j,m,ind,ind1,jjj
11129       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11130                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11131                  sint2,xp,yp,xxp,yyp,zzp,dj
11132
11133 !      common /przechowalnia/ fromto
11134       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11135 ! get the position of the jth ijth fragment of the chain coordinate system
11136 ! in the fromto array.
11137 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11138 !
11139 !      maxdim=(nres-1)*(nres-2)/2
11140 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11141 ! calculate the derivatives of transformation matrix elements in theta
11142 !
11143
11144 !el      call flush(iout) !el
11145       do i=1,nres-2
11146         rdt(1,1,i)=-rt(1,2,i)
11147         rdt(1,2,i)= rt(1,1,i)
11148         rdt(1,3,i)= 0.0d0
11149         rdt(2,1,i)=-rt(2,2,i)
11150         rdt(2,2,i)= rt(2,1,i)
11151         rdt(2,3,i)= 0.0d0
11152         rdt(3,1,i)=-rt(3,2,i)
11153         rdt(3,2,i)= rt(3,1,i)
11154         rdt(3,3,i)= 0.0d0
11155       enddo
11156 !
11157 ! derivatives in phi
11158 !
11159       do i=2,nres-2
11160         drt(1,1,i)= 0.0d0
11161         drt(1,2,i)= 0.0d0
11162         drt(1,3,i)= 0.0d0
11163         drt(2,1,i)= rt(3,1,i)
11164         drt(2,2,i)= rt(3,2,i)
11165         drt(2,3,i)= rt(3,3,i)
11166         drt(3,1,i)=-rt(2,1,i)
11167         drt(3,2,i)=-rt(2,2,i)
11168         drt(3,3,i)=-rt(2,3,i)
11169       enddo
11170 !
11171 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11172 !
11173       do i=2,nres-2
11174         ind=indmat(i,i+1)
11175         do k=1,3
11176           do l=1,3
11177             temp(k,l)=rt(k,l,i)
11178           enddo
11179         enddo
11180         do k=1,3
11181           do l=1,3
11182             fromto(k,l,ind)=temp(k,l)
11183           enddo
11184         enddo
11185         do j=i+1,nres-2
11186           ind=indmat(i,j+1)
11187           do k=1,3
11188             do l=1,3
11189               dpkl=0.0d0
11190               do m=1,3
11191                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11192               enddo
11193               dp(k,l)=dpkl
11194               fromto(k,l,ind)=dpkl
11195             enddo
11196           enddo
11197           do k=1,3
11198             do l=1,3
11199               temp(k,l)=dp(k,l)
11200             enddo
11201           enddo
11202         enddo
11203       enddo
11204 !
11205 ! Calculate derivatives.
11206 !
11207       ind1=0
11208       do i=1,nres-2
11209       ind1=ind1+1
11210 !
11211 ! Derivatives of DC(i+1) in theta(i+2)
11212 !
11213         do j=1,3
11214           do k=1,2
11215             dpjk=0.0D0
11216             do l=1,3
11217               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11218             enddo
11219             dp(j,k)=dpjk
11220             prordt(j,k,i)=dp(j,k)
11221           enddo
11222           dp(j,3)=0.0D0
11223           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11224         enddo
11225 !
11226 ! Derivatives of SC(i+1) in theta(i+2)
11227 !
11228         xx1(1)=-0.5D0*xloc(2,i+1)
11229         xx1(2)= 0.5D0*xloc(1,i+1)
11230         do j=1,3
11231           xj=0.0D0
11232           do k=1,2
11233             xj=xj+r(j,k,i)*xx1(k)
11234           enddo
11235           xx(j)=xj
11236         enddo
11237         do j=1,3
11238           rj=0.0D0
11239           do k=1,3
11240             rj=rj+prod(j,k,i)*xx(k)
11241           enddo
11242           dxdv(j,ind1)=rj
11243         enddo
11244 !
11245 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11246 ! than the other off-diagonal derivatives.
11247 !
11248         do j=1,3
11249           dxoiij=0.0D0
11250           do k=1,3
11251             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11252           enddo
11253           dxdv(j,ind1+1)=dxoiij
11254         enddo
11255 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11256 !
11257 ! Derivatives of DC(i+1) in phi(i+2)
11258 !
11259         do j=1,3
11260           do k=1,3
11261             dpjk=0.0
11262             do l=2,3
11263               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11264             enddo
11265             dp(j,k)=dpjk
11266             prodrt(j,k,i)=dp(j,k)
11267           enddo
11268           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11269         enddo
11270 !
11271 ! Derivatives of SC(i+1) in phi(i+2)
11272 !
11273         xx(1)= 0.0D0
11274         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11275         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11276         do j=1,3
11277           rj=0.0D0
11278           do k=2,3
11279             rj=rj+prod(j,k,i)*xx(k)
11280           enddo
11281           dxdv(j+3,ind1)=-rj
11282         enddo
11283 !
11284 ! Derivatives of SC(i+1) in phi(i+3).
11285 !
11286         do j=1,3
11287           dxoiij=0.0D0
11288           do k=1,3
11289             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11290           enddo
11291           dxdv(j+3,ind1+1)=dxoiij
11292         enddo
11293 !
11294 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11295 ! theta(nres) and phi(i+3) thru phi(nres).
11296 !
11297         do j=i+1,nres-2
11298         ind1=ind1+1
11299         ind=indmat(i+1,j+1)
11300 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11301           do k=1,3
11302             do l=1,3
11303               tempkl=0.0D0
11304               do m=1,2
11305                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11306               enddo
11307               temp(k,l)=tempkl
11308             enddo
11309           enddo
11310 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11311 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11312 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11313 ! Derivatives of virtual-bond vectors in theta
11314           do k=1,3
11315             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11316           enddo
11317 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11318 ! Derivatives of SC vectors in theta
11319           do k=1,3
11320             dxoijk=0.0D0
11321             do l=1,3
11322               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11323             enddo
11324             dxdv(k,ind1+1)=dxoijk
11325           enddo
11326 !
11327 !--- Calculate the derivatives in phi
11328 !
11329           do k=1,3
11330             do l=1,3
11331               tempkl=0.0D0
11332               do m=1,3
11333                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11334               enddo
11335               temp(k,l)=tempkl
11336             enddo
11337           enddo
11338           do k=1,3
11339             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11340         enddo
11341           do k=1,3
11342             dxoijk=0.0D0
11343             do l=1,3
11344               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11345             enddo
11346             dxdv(k+3,ind1+1)=dxoijk
11347           enddo
11348         enddo
11349       enddo
11350 !
11351 ! Derivatives in alpha and omega:
11352 !
11353       do i=2,nres-1
11354 !       dsci=dsc(itype(i,1))
11355         dsci=vbld(i+nres)
11356 #ifdef OSF
11357         alphi=alph(i)
11358         omegi=omeg(i)
11359         if(alphi.ne.alphi) alphi=100.0
11360         if(omegi.ne.omegi) omegi=-100.0
11361 #else
11362       alphi=alph(i)
11363       omegi=omeg(i)
11364 #endif
11365 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11366       cosalphi=dcos(alphi)
11367       sinalphi=dsin(alphi)
11368       cosomegi=dcos(omegi)
11369       sinomegi=dsin(omegi)
11370       temp(1,1)=-dsci*sinalphi
11371       temp(2,1)= dsci*cosalphi*cosomegi
11372       temp(3,1)=-dsci*cosalphi*sinomegi
11373       temp(1,2)=0.0D0
11374       temp(2,2)=-dsci*sinalphi*sinomegi
11375       temp(3,2)=-dsci*sinalphi*cosomegi
11376       theta2=pi-0.5D0*theta(i+1)
11377       cost2=dcos(theta2)
11378       sint2=dsin(theta2)
11379       jjj=0
11380 !d      print *,((temp(l,k),l=1,3),k=1,2)
11381         do j=1,2
11382         xp=temp(1,j)
11383         yp=temp(2,j)
11384         xxp= xp*cost2+yp*sint2
11385         yyp=-xp*sint2+yp*cost2
11386         zzp=temp(3,j)
11387         xx(1)=xxp
11388         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11389         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11390         do k=1,3
11391           dj=0.0D0
11392           do l=1,3
11393             dj=dj+prod(k,l,i-1)*xx(l)
11394             enddo
11395           dxds(jjj+k,i)=dj
11396           enddo
11397         jjj=jjj+3
11398       enddo
11399       enddo
11400       return
11401       end subroutine cartder
11402 !-----------------------------------------------------------------------------
11403 ! checkder_p.F
11404 !-----------------------------------------------------------------------------
11405       subroutine check_cartgrad
11406 ! Check the gradient of Cartesian coordinates in internal coordinates.
11407 !      implicit real*8 (a-h,o-z)
11408 !      include 'DIMENSIONS'
11409 !      include 'COMMON.IOUNITS'
11410 !      include 'COMMON.VAR'
11411 !      include 'COMMON.CHAIN'
11412 !      include 'COMMON.GEO'
11413 !      include 'COMMON.LOCAL'
11414 !      include 'COMMON.DERIV'
11415       real(kind=8),dimension(6,nres) :: temp
11416       real(kind=8),dimension(3) :: xx,gg
11417       integer :: i,k,j,ii
11418       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11419 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11420 !
11421 ! Check the gradient of the virtual-bond and SC vectors in the internal
11422 ! coordinates.
11423 !
11424       aincr=1.0d-6
11425       aincr2=5.0d-7
11426       call cartder
11427       write (iout,'(a)') '**************** dx/dalpha'
11428       write (iout,'(a)')
11429       do i=2,nres-1
11430       alphi=alph(i)
11431       alph(i)=alph(i)+aincr
11432       do k=1,3
11433         temp(k,i)=dc(k,nres+i)
11434         enddo
11435       call chainbuild
11436       do k=1,3
11437         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11438         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11439         enddo
11440         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11441         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11442         write (iout,'(a)')
11443       alph(i)=alphi
11444       call chainbuild
11445       enddo
11446       write (iout,'(a)')
11447       write (iout,'(a)') '**************** dx/domega'
11448       write (iout,'(a)')
11449       do i=2,nres-1
11450       omegi=omeg(i)
11451       omeg(i)=omeg(i)+aincr
11452       do k=1,3
11453         temp(k,i)=dc(k,nres+i)
11454         enddo
11455       call chainbuild
11456       do k=1,3
11457           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11458           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11459                 (aincr*dabs(dxds(k+3,i))+aincr))
11460         enddo
11461         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11462             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11463         write (iout,'(a)')
11464       omeg(i)=omegi
11465       call chainbuild
11466       enddo
11467       write (iout,'(a)')
11468       write (iout,'(a)') '**************** dx/dtheta'
11469       write (iout,'(a)')
11470       do i=3,nres
11471       theti=theta(i)
11472         theta(i)=theta(i)+aincr
11473         do j=i-1,nres-1
11474           do k=1,3
11475             temp(k,j)=dc(k,nres+j)
11476           enddo
11477         enddo
11478         call chainbuild
11479         do j=i-1,nres-1
11480         ii = indmat(i-2,j)
11481 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11482         do k=1,3
11483           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11484           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11485                   (aincr*dabs(dxdv(k,ii))+aincr))
11486           enddo
11487           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11488               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11489           write(iout,'(a)')
11490         enddo
11491         write (iout,'(a)')
11492         theta(i)=theti
11493         call chainbuild
11494       enddo
11495       write (iout,'(a)') '***************** dx/dphi'
11496       write (iout,'(a)')
11497       do i=4,nres
11498         phi(i)=phi(i)+aincr
11499         do j=i-1,nres-1
11500           do k=1,3
11501             temp(k,j)=dc(k,nres+j)
11502           enddo
11503         enddo
11504         call chainbuild
11505         do j=i-1,nres-1
11506         ii = indmat(i-2,j)
11507 !         print *,'ii=',ii
11508         do k=1,3
11509           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11510             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11511                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11512           enddo
11513           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11514               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11515           write(iout,'(a)')
11516         enddo
11517         phi(i)=phi(i)-aincr
11518         call chainbuild
11519       enddo
11520       write (iout,'(a)') '****************** ddc/dtheta'
11521       do i=1,nres-2
11522         thet=theta(i+2)
11523         theta(i+2)=thet+aincr
11524         do j=i,nres
11525           do k=1,3
11526             temp(k,j)=dc(k,j)
11527           enddo
11528         enddo
11529         call chainbuild
11530         do j=i+1,nres-1
11531         ii = indmat(i,j)
11532 !         print *,'ii=',ii
11533         do k=1,3
11534           gg(k)=(dc(k,j)-temp(k,j))/aincr
11535           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11536                  (aincr*dabs(dcdv(k,ii))+aincr))
11537           enddo
11538           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11539                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11540         write (iout,'(a)')
11541         enddo
11542         do j=1,nres
11543           do k=1,3
11544             dc(k,j)=temp(k,j)
11545           enddo
11546         enddo
11547         theta(i+2)=thet
11548       enddo
11549       write (iout,'(a)') '******************* ddc/dphi'
11550       do i=1,nres-3
11551         phii=phi(i+3)
11552         phi(i+3)=phii+aincr
11553         do j=1,nres
11554           do k=1,3
11555             temp(k,j)=dc(k,j)
11556           enddo
11557         enddo
11558         call chainbuild
11559         do j=i+2,nres-1
11560         ii = indmat(i+1,j)
11561 !         print *,'ii=',ii
11562         do k=1,3
11563           gg(k)=(dc(k,j)-temp(k,j))/aincr
11564             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11565                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11566           enddo
11567           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11568                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11569         write (iout,'(a)')
11570         enddo
11571         do j=1,nres
11572           do k=1,3
11573             dc(k,j)=temp(k,j)
11574           enddo
11575         enddo
11576         phi(i+3)=phii
11577       enddo
11578       return
11579       end subroutine check_cartgrad
11580 !-----------------------------------------------------------------------------
11581       subroutine check_ecart
11582 ! Check the gradient of the energy in Cartesian coordinates.
11583 !     implicit real*8 (a-h,o-z)
11584 !     include 'DIMENSIONS'
11585 !     include 'COMMON.CHAIN'
11586 !     include 'COMMON.DERIV'
11587 !     include 'COMMON.IOUNITS'
11588 !     include 'COMMON.VAR'
11589 !     include 'COMMON.CONTACTS'
11590       use comm_srutu
11591 !el      integer :: icall
11592 !el      common /srutu/ icall
11593       real(kind=8),dimension(6) :: ggg
11594       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11595       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11596       real(kind=8),dimension(6,nres) :: grad_s
11597       real(kind=8),dimension(0:n_ene) :: energia,energia1
11598       integer :: uiparm(1)
11599       real(kind=8) :: urparm(1)
11600 !EL      external fdum
11601       integer :: nf,i,j,k
11602       real(kind=8) :: aincr,etot,etot1
11603       icg=1
11604       nf=0
11605       nfl=0
11606       call zerograd
11607       aincr=1.0D-5
11608       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11609       nf=0
11610       icall=0
11611       call geom_to_var(nvar,x)
11612       call etotal(energia)
11613       etot=energia(0)
11614 !el      call enerprint(energia)
11615       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11616       icall =1
11617       do i=1,nres
11618         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11619       enddo
11620       do i=1,nres
11621       do j=1,3
11622         grad_s(j,i)=gradc(j,i,icg)
11623         grad_s(j+3,i)=gradx(j,i,icg)
11624         enddo
11625       enddo
11626       call flush(iout)
11627       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11628       do i=1,nres
11629         do j=1,3
11630         xx(j)=c(j,i+nres)
11631         ddc(j)=dc(j,i)
11632         ddx(j)=dc(j,i+nres)
11633         enddo
11634       do j=1,3
11635         dc(j,i)=dc(j,i)+aincr
11636         do k=i+1,nres
11637           c(j,k)=c(j,k)+aincr
11638           c(j,k+nres)=c(j,k+nres)+aincr
11639           enddo
11640           call etotal(energia1)
11641           etot1=energia1(0)
11642         ggg(j)=(etot1-etot)/aincr
11643         dc(j,i)=ddc(j)
11644         do k=i+1,nres
11645           c(j,k)=c(j,k)-aincr
11646           c(j,k+nres)=c(j,k+nres)-aincr
11647           enddo
11648         enddo
11649       do j=1,3
11650         c(j,i+nres)=c(j,i+nres)+aincr
11651         dc(j,i+nres)=dc(j,i+nres)+aincr
11652           call etotal(energia1)
11653           etot1=energia1(0)
11654         ggg(j+3)=(etot1-etot)/aincr
11655         c(j,i+nres)=xx(j)
11656         dc(j,i+nres)=ddx(j)
11657         enddo
11658       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11659          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11660       enddo
11661       return
11662       end subroutine check_ecart
11663 #ifdef CARGRAD
11664 !-----------------------------------------------------------------------------
11665       subroutine check_ecartint
11666 ! Check the gradient of the energy in Cartesian coordinates.
11667       use io_base, only: intout
11668 !      implicit real*8 (a-h,o-z)
11669 !      include 'DIMENSIONS'
11670 !      include 'COMMON.CONTROL'
11671 !      include 'COMMON.CHAIN'
11672 !      include 'COMMON.DERIV'
11673 !      include 'COMMON.IOUNITS'
11674 !      include 'COMMON.VAR'
11675 !      include 'COMMON.CONTACTS'
11676 !      include 'COMMON.MD'
11677 !      include 'COMMON.LOCAL'
11678 !      include 'COMMON.SPLITELE'
11679       use comm_srutu
11680 !el      integer :: icall
11681 !el      common /srutu/ icall
11682       real(kind=8),dimension(6) :: ggg,ggg1
11683       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11684       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11685       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11686       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11687       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11688       real(kind=8),dimension(0:n_ene) :: energia,energia1
11689       integer :: uiparm(1)
11690       real(kind=8) :: urparm(1)
11691 !EL      external fdum
11692       integer :: i,j,k,nf
11693       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11694                    etot21,etot22
11695       r_cut=2.0d0
11696       rlambd=0.3d0
11697       icg=1
11698       nf=0
11699       nfl=0
11700       call intout
11701 !      call intcartderiv
11702 !      call checkintcartgrad
11703       call zerograd
11704       aincr=1.0D-5
11705       write(iout,*) 'Calling CHECK_ECARTINT.'
11706       nf=0
11707       icall=0
11708       write (iout,*) "Before geom_to_var"
11709       call geom_to_var(nvar,x)
11710       write (iout,*) "after geom_to_var"
11711       write (iout,*) "split_ene ",split_ene
11712       call flush(iout)
11713       if (.not.split_ene) then
11714         write(iout,*) 'Calling CHECK_ECARTINT if'
11715         call etotal(energia)
11716 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11717         etot=energia(0)
11718         write (iout,*) "etot",etot
11719         call flush(iout)
11720 !el        call enerprint(energia)
11721 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11722         call flush(iout)
11723         write (iout,*) "enter cartgrad"
11724         call flush(iout)
11725         call cartgrad
11726 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11727         write (iout,*) "exit cartgrad"
11728         call flush(iout)
11729         icall =1
11730         do i=1,nres
11731           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11732         enddo
11733         do j=1,3
11734           grad_s(j,0)=gcart(j,0)
11735         enddo
11736 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11737         do i=1,nres
11738           do j=1,3
11739             grad_s(j,i)=gcart(j,i)
11740             grad_s(j+3,i)=gxcart(j,i)
11741           enddo
11742         enddo
11743       else
11744 write(iout,*) 'Calling CHECK_ECARTIN else.'
11745 !- split gradient check
11746         call zerograd
11747         call etotal_long(energia)
11748 !el        call enerprint(energia)
11749         call flush(iout)
11750         write (iout,*) "enter cartgrad"
11751         call flush(iout)
11752         call cartgrad
11753         write (iout,*) "exit cartgrad"
11754         call flush(iout)
11755         icall =1
11756         write (iout,*) "longrange grad"
11757         do i=1,nres
11758           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11759           (gxcart(j,i),j=1,3)
11760         enddo
11761         do j=1,3
11762           grad_s(j,0)=gcart(j,0)
11763         enddo
11764         do i=1,nres
11765           do j=1,3
11766             grad_s(j,i)=gcart(j,i)
11767             grad_s(j+3,i)=gxcart(j,i)
11768           enddo
11769         enddo
11770         call zerograd
11771         call etotal_short(energia)
11772         call enerprint(energia)
11773         call flush(iout)
11774         write (iout,*) "enter cartgrad"
11775         call flush(iout)
11776         call cartgrad
11777         write (iout,*) "exit cartgrad"
11778         call flush(iout)
11779         icall =1
11780         write (iout,*) "shortrange grad"
11781         do i=1,nres
11782           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11783           (gxcart(j,i),j=1,3)
11784         enddo
11785         do j=1,3
11786           grad_s1(j,0)=gcart(j,0)
11787         enddo
11788         do i=1,nres
11789           do j=1,3
11790             grad_s1(j,i)=gcart(j,i)
11791             grad_s1(j+3,i)=gxcart(j,i)
11792           enddo
11793         enddo
11794       endif
11795       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11796 !      do i=1,nres
11797       do i=nnt,nct
11798         do j=1,3
11799           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11800           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11801         ddc(j)=c(j,i)
11802         ddx(j)=c(j,i+nres)
11803           dcnorm_safe1(j)=dc_norm(j,i-1)
11804           dcnorm_safe2(j)=dc_norm(j,i)
11805           dxnorm_safe(j)=dc_norm(j,i+nres)
11806         enddo
11807       do j=1,3
11808         c(j,i)=ddc(j)+aincr
11809           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11810           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11811           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11812           dc(j,i)=c(j,i+1)-c(j,i)
11813           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11814           call int_from_cart1(.false.)
11815           if (.not.split_ene) then
11816             call etotal(energia1)
11817             etot1=energia1(0)
11818             write (iout,*) "ij",i,j," etot1",etot1
11819           else
11820 !- split gradient
11821             call etotal_long(energia1)
11822             etot11=energia1(0)
11823             call etotal_short(energia1)
11824             etot12=energia1(0)
11825           endif
11826 !- end split gradient
11827 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11828         c(j,i)=ddc(j)-aincr
11829           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11830           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11831           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11832           dc(j,i)=c(j,i+1)-c(j,i)
11833           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11834           call int_from_cart1(.false.)
11835           if (.not.split_ene) then
11836             call etotal(energia1)
11837             etot2=energia1(0)
11838             write (iout,*) "ij",i,j," etot2",etot2
11839           ggg(j)=(etot1-etot2)/(2*aincr)
11840           else
11841 !- split gradient
11842             call etotal_long(energia1)
11843             etot21=energia1(0)
11844           ggg(j)=(etot11-etot21)/(2*aincr)
11845             call etotal_short(energia1)
11846             etot22=energia1(0)
11847           ggg1(j)=(etot12-etot22)/(2*aincr)
11848 !- end split gradient
11849 !            write (iout,*) "etot21",etot21," etot22",etot22
11850           endif
11851 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11852         c(j,i)=ddc(j)
11853           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11854           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11855           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11856           dc(j,i)=c(j,i+1)-c(j,i)
11857           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11858           dc_norm(j,i-1)=dcnorm_safe1(j)
11859           dc_norm(j,i)=dcnorm_safe2(j)
11860           dc_norm(j,i+nres)=dxnorm_safe(j)
11861         enddo
11862       do j=1,3
11863         c(j,i+nres)=ddx(j)+aincr
11864           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11865           call int_from_cart1(.false.)
11866           if (.not.split_ene) then
11867             call etotal(energia1)
11868             etot1=energia1(0)
11869           else
11870 !- split gradient
11871             call etotal_long(energia1)
11872             etot11=energia1(0)
11873             call etotal_short(energia1)
11874             etot12=energia1(0)
11875           endif
11876 !- end split gradient
11877         c(j,i+nres)=ddx(j)-aincr
11878           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11879           call int_from_cart1(.false.)
11880           if (.not.split_ene) then
11881             call etotal(energia1)
11882             etot2=energia1(0)
11883           ggg(j+3)=(etot1-etot2)/(2*aincr)
11884           else
11885 !- split gradient
11886             call etotal_long(energia1)
11887             etot21=energia1(0)
11888           ggg(j+3)=(etot11-etot21)/(2*aincr)
11889             call etotal_short(energia1)
11890             etot22=energia1(0)
11891           ggg1(j+3)=(etot12-etot22)/(2*aincr)
11892 !- end split gradient
11893           endif
11894 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11895         c(j,i+nres)=ddx(j)
11896           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11897           dc_norm(j,i+nres)=dxnorm_safe(j)
11898           call int_from_cart1(.false.)
11899         enddo
11900       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11901          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11902         if (split_ene) then
11903           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11904          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11905          k=1,6)
11906          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11907          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11908          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11909         endif
11910       enddo
11911       return
11912       end subroutine check_ecartint
11913 #else
11914 !-----------------------------------------------------------------------------
11915       subroutine check_ecartint
11916 ! Check the gradient of the energy in Cartesian coordinates.
11917       use io_base, only: intout
11918 !      implicit real*8 (a-h,o-z)
11919 !      include 'DIMENSIONS'
11920 !      include 'COMMON.CONTROL'
11921 !      include 'COMMON.CHAIN'
11922 !      include 'COMMON.DERIV'
11923 !      include 'COMMON.IOUNITS'
11924 !      include 'COMMON.VAR'
11925 !      include 'COMMON.CONTACTS'
11926 !      include 'COMMON.MD'
11927 !      include 'COMMON.LOCAL'
11928 !      include 'COMMON.SPLITELE'
11929       use comm_srutu
11930 !el      integer :: icall
11931 !el      common /srutu/ icall
11932       real(kind=8),dimension(6) :: ggg,ggg1
11933       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11934       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11935       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
11936       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11937       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11938       real(kind=8),dimension(0:n_ene) :: energia,energia1
11939       integer :: uiparm(1)
11940       real(kind=8) :: urparm(1)
11941 !EL      external fdum
11942       integer :: i,j,k,nf
11943       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11944                    etot21,etot22
11945       r_cut=2.0d0
11946       rlambd=0.3d0
11947       icg=1
11948       nf=0
11949       nfl=0
11950       call intout
11951 !      call intcartderiv
11952 !      call checkintcartgrad
11953       call zerograd
11954       aincr=2.0D-5
11955       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
11956       nf=0
11957       icall=0
11958       call geom_to_var(nvar,x)
11959       if (.not.split_ene) then
11960         call etotal(energia)
11961         etot=energia(0)
11962 !el        call enerprint(energia)
11963         call flush(iout)
11964         write (iout,*) "enter cartgrad"
11965         call flush(iout)
11966         call cartgrad
11967         write (iout,*) "exit cartgrad"
11968         call flush(iout)
11969         icall =1
11970         do i=1,nres
11971           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11972         enddo
11973         do j=1,3
11974           grad_s(j,0)=gcart(j,0)
11975         enddo
11976         do i=1,nres
11977           do j=1,3
11978             grad_s(j,i)=gcart(j,i)
11979 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
11980             grad_s(j+3,i)=gxcart(j,i)
11981           enddo
11982         enddo
11983       else
11984 !- split gradient check
11985         call zerograd
11986         call etotal_long(energia)
11987 !el        call enerprint(energia)
11988         call flush(iout)
11989         write (iout,*) "enter cartgrad"
11990         call flush(iout)
11991         call cartgrad
11992         write (iout,*) "exit cartgrad"
11993         call flush(iout)
11994         icall =1
11995         write (iout,*) "longrange grad"
11996         do i=1,nres
11997           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11998           (gxcart(j,i),j=1,3)
11999         enddo
12000         do j=1,3
12001           grad_s(j,0)=gcart(j,0)
12002         enddo
12003         do i=1,nres
12004           do j=1,3
12005             grad_s(j,i)=gcart(j,i)
12006             grad_s(j+3,i)=gxcart(j,i)
12007           enddo
12008         enddo
12009         call zerograd
12010         call etotal_short(energia)
12011 !el        call enerprint(energia)
12012         call flush(iout)
12013         write (iout,*) "enter cartgrad"
12014         call flush(iout)
12015         call cartgrad
12016         write (iout,*) "exit cartgrad"
12017         call flush(iout)
12018         icall =1
12019         write (iout,*) "shortrange grad"
12020         do i=1,nres
12021           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12022           (gxcart(j,i),j=1,3)
12023         enddo
12024         do j=1,3
12025           grad_s1(j,0)=gcart(j,0)
12026         enddo
12027         do i=1,nres
12028           do j=1,3
12029             grad_s1(j,i)=gcart(j,i)
12030             grad_s1(j+3,i)=gxcart(j,i)
12031           enddo
12032         enddo
12033       endif
12034       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12035       do i=0,nres
12036         do j=1,3
12037         xx(j)=c(j,i+nres)
12038         ddc(j)=dc(j,i)
12039         ddx(j)=dc(j,i+nres)
12040           do k=1,3
12041             dcnorm_safe(k)=dc_norm(k,i)
12042             dxnorm_safe(k)=dc_norm(k,i+nres)
12043           enddo
12044         enddo
12045       do j=1,3
12046         dc(j,i)=ddc(j)+aincr
12047           call chainbuild_cart
12048 #ifdef MPI
12049 ! Broadcast the order to compute internal coordinates to the slaves.
12050 !          if (nfgtasks.gt.1)
12051 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12052 #endif
12053 !          call int_from_cart1(.false.)
12054           if (.not.split_ene) then
12055             call etotal(energia1)
12056             etot1=energia1(0)
12057 !            call enerprint(energia1)
12058           else
12059 !- split gradient
12060             call etotal_long(energia1)
12061             etot11=energia1(0)
12062             call etotal_short(energia1)
12063             etot12=energia1(0)
12064 !            write (iout,*) "etot11",etot11," etot12",etot12
12065           endif
12066 !- end split gradient
12067 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12068         dc(j,i)=ddc(j)-aincr
12069           call chainbuild_cart
12070 !          call int_from_cart1(.false.)
12071           if (.not.split_ene) then
12072             call etotal(energia1)
12073             etot2=energia1(0)
12074           ggg(j)=(etot1-etot2)/(2*aincr)
12075           else
12076 !- split gradient
12077             call etotal_long(energia1)
12078             etot21=energia1(0)
12079           ggg(j)=(etot11-etot21)/(2*aincr)
12080             call etotal_short(energia1)
12081             etot22=energia1(0)
12082           ggg1(j)=(etot12-etot22)/(2*aincr)
12083 !- end split gradient
12084 !            write (iout,*) "etot21",etot21," etot22",etot22
12085           endif
12086 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12087         dc(j,i)=ddc(j)
12088           call chainbuild_cart
12089         enddo
12090       do j=1,3
12091         dc(j,i+nres)=ddx(j)+aincr
12092           call chainbuild_cart
12093 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12094 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12095 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12096 !          write (iout,*) "dxnormnorm",dsqrt(
12097 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12098 !          write (iout,*) "dxnormnormsafe",dsqrt(
12099 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12100 !          write (iout,*)
12101           if (.not.split_ene) then
12102             call etotal(energia1)
12103             etot1=energia1(0)
12104           else
12105 !- split gradient
12106             call etotal_long(energia1)
12107             etot11=energia1(0)
12108             call etotal_short(energia1)
12109             etot12=energia1(0)
12110           endif
12111 !- end split gradient
12112 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12113         dc(j,i+nres)=ddx(j)-aincr
12114           call chainbuild_cart
12115 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12116 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12117 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12118 !          write (iout,*)
12119 !          write (iout,*) "dxnormnorm",dsqrt(
12120 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12121 !          write (iout,*) "dxnormnormsafe",dsqrt(
12122 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12123           if (.not.split_ene) then
12124             call etotal(energia1)
12125             etot2=energia1(0)
12126           ggg(j+3)=(etot1-etot2)/(2*aincr)
12127           else
12128 !- split gradient
12129             call etotal_long(energia1)
12130             etot21=energia1(0)
12131           ggg(j+3)=(etot11-etot21)/(2*aincr)
12132             call etotal_short(energia1)
12133             etot22=energia1(0)
12134           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12135 !- end split gradient
12136           endif
12137 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12138         dc(j,i+nres)=ddx(j)
12139           call chainbuild_cart
12140         enddo
12141       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12142          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12143         if (split_ene) then
12144           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12145          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12146          k=1,6)
12147          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12148          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12149          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12150         endif
12151       enddo
12152       return
12153       end subroutine check_ecartint
12154 #endif
12155 !-----------------------------------------------------------------------------
12156       subroutine check_eint
12157 ! Check the gradient of energy in internal coordinates.
12158 !      implicit real*8 (a-h,o-z)
12159 !      include 'DIMENSIONS'
12160 !      include 'COMMON.CHAIN'
12161 !      include 'COMMON.DERIV'
12162 !      include 'COMMON.IOUNITS'
12163 !      include 'COMMON.VAR'
12164 !      include 'COMMON.GEO'
12165       use comm_srutu
12166 !el      integer :: icall
12167 !el      common /srutu/ icall
12168       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12169       integer :: uiparm(1)
12170       real(kind=8) :: urparm(1)
12171       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12172       character(len=6) :: key
12173 !EL      external fdum
12174       integer :: i,ii,nf
12175       real(kind=8) :: xi,aincr,etot,etot1,etot2
12176       call zerograd
12177       aincr=1.0D-7
12178       print '(a)','Calling CHECK_INT.'
12179       nf=0
12180       nfl=0
12181       icg=1
12182       call geom_to_var(nvar,x)
12183       call var_to_geom(nvar,x)
12184       call chainbuild
12185       icall=1
12186 !      print *,'ICG=',ICG
12187       call etotal(energia)
12188       etot = energia(0)
12189 !el      call enerprint(energia)
12190 !      print *,'ICG=',ICG
12191 #ifdef MPL
12192       if (MyID.ne.BossID) then
12193         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12194         nf=x(nvar+1)
12195         nfl=x(nvar+2)
12196         icg=x(nvar+3)
12197       endif
12198 #endif
12199       nf=1
12200       nfl=3
12201 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12202       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12203 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12204       icall=1
12205       do i=1,nvar
12206         xi=x(i)
12207         x(i)=xi-0.5D0*aincr
12208         call var_to_geom(nvar,x)
12209         call chainbuild
12210         call etotal(energia1)
12211         etot1=energia1(0)
12212         x(i)=xi+0.5D0*aincr
12213         call var_to_geom(nvar,x)
12214         call chainbuild
12215         call etotal(energia2)
12216         etot2=energia2(0)
12217         gg(i)=(etot2-etot1)/aincr
12218         write (iout,*) i,etot1,etot2
12219         x(i)=xi
12220       enddo
12221       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12222           '     RelDiff*100% '
12223       do i=1,nvar
12224         if (i.le.nphi) then
12225           ii=i
12226           key = ' phi'
12227         else if (i.le.nphi+ntheta) then
12228           ii=i-nphi
12229           key=' theta'
12230         else if (i.le.nphi+ntheta+nside) then
12231            ii=i-(nphi+ntheta)
12232            key=' alpha'
12233         else
12234            ii=i-(nphi+ntheta+nside)
12235            key=' omega'
12236         endif
12237         write (iout,'(i3,a,i3,3(1pd16.6))') &
12238        i,key,ii,gg(i),gana(i),&
12239        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12240       enddo
12241       return
12242       end subroutine check_eint
12243 !-----------------------------------------------------------------------------
12244 ! econstr_local.F
12245 !-----------------------------------------------------------------------------
12246       subroutine Econstr_back
12247 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12248 !      implicit real*8 (a-h,o-z)
12249 !      include 'DIMENSIONS'
12250 !      include 'COMMON.CONTROL'
12251 !      include 'COMMON.VAR'
12252 !      include 'COMMON.MD'
12253       use MD_data
12254 !#ifndef LANG0
12255 !      include 'COMMON.LANGEVIN'
12256 !#else
12257 !      include 'COMMON.LANGEVIN.lang0'
12258 !#endif
12259 !      include 'COMMON.CHAIN'
12260 !      include 'COMMON.DERIV'
12261 !      include 'COMMON.GEO'
12262 !      include 'COMMON.LOCAL'
12263 !      include 'COMMON.INTERACT'
12264 !      include 'COMMON.IOUNITS'
12265 !      include 'COMMON.NAMES'
12266 !      include 'COMMON.TIME1'
12267       integer :: i,j,ii,k
12268       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12269
12270       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12271       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12272       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12273
12274       Uconst_back=0.0d0
12275       do i=1,nres
12276         dutheta(i)=0.0d0
12277         dugamma(i)=0.0d0
12278         do j=1,3
12279           duscdiff(j,i)=0.0d0
12280           duscdiffx(j,i)=0.0d0
12281         enddo
12282       enddo
12283       do i=1,nfrag_back
12284         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12285 !
12286 ! Deviations from theta angles
12287 !
12288         utheta_i=0.0d0
12289         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12290           dtheta_i=theta(j)-thetaref(j)
12291           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12292           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12293         enddo
12294         utheta(i)=utheta_i/(ii-1)
12295 !
12296 ! Deviations from gamma angles
12297 !
12298         ugamma_i=0.0d0
12299         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12300           dgamma_i=pinorm(phi(j)-phiref(j))
12301 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12302           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12303           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12304 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12305         enddo
12306         ugamma(i)=ugamma_i/(ii-2)
12307 !
12308 ! Deviations from local SC geometry
12309 !
12310         uscdiff(i)=0.0d0
12311         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12312           dxx=xxtab(j)-xxref(j)
12313           dyy=yytab(j)-yyref(j)
12314           dzz=zztab(j)-zzref(j)
12315           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12316           do k=1,3
12317             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12318              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12319              (ii-1)
12320             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12321              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12322              (ii-1)
12323             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12324            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12325             /(ii-1)
12326           enddo
12327 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12328 !     &      xxref(j),yyref(j),zzref(j)
12329         enddo
12330         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12331 !        write (iout,*) i," uscdiff",uscdiff(i)
12332 !
12333 ! Put together deviations from local geometry
12334 !
12335         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12336           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12337 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12338 !     &   " uconst_back",uconst_back
12339         utheta(i)=dsqrt(utheta(i))
12340         ugamma(i)=dsqrt(ugamma(i))
12341         uscdiff(i)=dsqrt(uscdiff(i))
12342       enddo
12343       return
12344       end subroutine Econstr_back
12345 !-----------------------------------------------------------------------------
12346 ! energy_p_new-sep_barrier.F
12347 !-----------------------------------------------------------------------------
12348       real(kind=8) function sscale(r)
12349 !      include "COMMON.SPLITELE"
12350       real(kind=8) :: r,gamm
12351       if(r.lt.r_cut-rlamb) then
12352         sscale=1.0d0
12353       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12354         gamm=(r-(r_cut-rlamb))/rlamb
12355         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12356       else
12357         sscale=0d0
12358       endif
12359       return
12360       end function sscale
12361       real(kind=8) function sscale_grad(r)
12362 !      include "COMMON.SPLITELE"
12363       real(kind=8) :: r,gamm
12364       if(r.lt.r_cut-rlamb) then
12365         sscale_grad=0.0d0
12366       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12367         gamm=(r-(r_cut-rlamb))/rlamb
12368         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12369       else
12370         sscale_grad=0d0
12371       endif
12372       return
12373       end function sscale_grad
12374
12375 !!!!!!!!!! PBCSCALE
12376       real(kind=8) function sscale_ele(r)
12377 !      include "COMMON.SPLITELE"
12378       real(kind=8) :: r,gamm
12379       if(r.lt.r_cut_ele-rlamb_ele) then
12380         sscale_ele=1.0d0
12381       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12382         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12383         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12384       else
12385         sscale_ele=0d0
12386       endif
12387       return
12388       end function sscale_ele
12389
12390       real(kind=8)  function sscagrad_ele(r)
12391       real(kind=8) :: r,gamm
12392 !      include "COMMON.SPLITELE"
12393       if(r.lt.r_cut_ele-rlamb_ele) then
12394         sscagrad_ele=0.0d0
12395       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12396         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12397         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12398       else
12399         sscagrad_ele=0.0d0
12400       endif
12401       return
12402       end function sscagrad_ele
12403       real(kind=8) function sscalelip(r)
12404       real(kind=8) r,gamm
12405         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12406       return
12407       end function sscalelip
12408 !C-----------------------------------------------------------------------
12409       real(kind=8) function sscagradlip(r)
12410       real(kind=8) r,gamm
12411         sscagradlip=r*(6.0d0*r-6.0d0)
12412       return
12413       end function sscagradlip
12414
12415 !!!!!!!!!!!!!!!
12416 !-----------------------------------------------------------------------------
12417       subroutine elj_long(evdw)
12418 !
12419 ! This subroutine calculates the interaction energy of nonbonded side chains
12420 ! assuming the LJ potential of interaction.
12421 !
12422 !      implicit real*8 (a-h,o-z)
12423 !      include 'DIMENSIONS'
12424 !      include 'COMMON.GEO'
12425 !      include 'COMMON.VAR'
12426 !      include 'COMMON.LOCAL'
12427 !      include 'COMMON.CHAIN'
12428 !      include 'COMMON.DERIV'
12429 !      include 'COMMON.INTERACT'
12430 !      include 'COMMON.TORSION'
12431 !      include 'COMMON.SBRIDGE'
12432 !      include 'COMMON.NAMES'
12433 !      include 'COMMON.IOUNITS'
12434 !      include 'COMMON.CONTACTS'
12435       real(kind=8),parameter :: accur=1.0d-10
12436       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12437 !el local variables
12438       integer :: i,iint,j,k,itypi,itypi1,itypj
12439       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12440       real(kind=8) :: e1,e2,evdwij,evdw
12441 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12442       evdw=0.0D0
12443       do i=iatsc_s,iatsc_e
12444         itypi=itype(i,1)
12445         if (itypi.eq.ntyp1) cycle
12446         itypi1=itype(i+1,1)
12447         xi=c(1,nres+i)
12448         yi=c(2,nres+i)
12449         zi=c(3,nres+i)
12450 !
12451 ! Calculate SC interaction energy.
12452 !
12453         do iint=1,nint_gr(i)
12454 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12455 !d   &                  'iend=',iend(i,iint)
12456           do j=istart(i,iint),iend(i,iint)
12457             itypj=itype(j,1)
12458             if (itypj.eq.ntyp1) cycle
12459             xj=c(1,nres+j)-xi
12460             yj=c(2,nres+j)-yi
12461             zj=c(3,nres+j)-zi
12462             rij=xj*xj+yj*yj+zj*zj
12463             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12464             if (sss.lt.1.0d0) then
12465               rrij=1.0D0/rij
12466               eps0ij=eps(itypi,itypj)
12467               fac=rrij**expon2
12468               e1=fac*fac*aa_aq(itypi,itypj)
12469               e2=fac*bb_aq(itypi,itypj)
12470               evdwij=e1+e2
12471               evdw=evdw+(1.0d0-sss)*evdwij
12472 !
12473 ! Calculate the components of the gradient in DC and X
12474 !
12475               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12476               gg(1)=xj*fac
12477               gg(2)=yj*fac
12478               gg(3)=zj*fac
12479               do k=1,3
12480                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12481                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12482                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12483                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12484               enddo
12485             endif
12486           enddo      ! j
12487         enddo        ! iint
12488       enddo          ! i
12489       do i=1,nct
12490         do j=1,3
12491           gvdwc(j,i)=expon*gvdwc(j,i)
12492           gvdwx(j,i)=expon*gvdwx(j,i)
12493         enddo
12494       enddo
12495 !******************************************************************************
12496 !
12497 !                              N O T E !!!
12498 !
12499 ! To save time, the factor of EXPON has been extracted from ALL components
12500 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12501 ! use!
12502 !
12503 !******************************************************************************
12504       return
12505       end subroutine elj_long
12506 !-----------------------------------------------------------------------------
12507       subroutine elj_short(evdw)
12508 !
12509 ! This subroutine calculates the interaction energy of nonbonded side chains
12510 ! assuming the LJ potential of interaction.
12511 !
12512 !      implicit real*8 (a-h,o-z)
12513 !      include 'DIMENSIONS'
12514 !      include 'COMMON.GEO'
12515 !      include 'COMMON.VAR'
12516 !      include 'COMMON.LOCAL'
12517 !      include 'COMMON.CHAIN'
12518 !      include 'COMMON.DERIV'
12519 !      include 'COMMON.INTERACT'
12520 !      include 'COMMON.TORSION'
12521 !      include 'COMMON.SBRIDGE'
12522 !      include 'COMMON.NAMES'
12523 !      include 'COMMON.IOUNITS'
12524 !      include 'COMMON.CONTACTS'
12525       real(kind=8),parameter :: accur=1.0d-10
12526       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12527 !el local variables
12528       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12529       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12530       real(kind=8) :: e1,e2,evdwij,evdw
12531 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12532       evdw=0.0D0
12533       do i=iatsc_s,iatsc_e
12534         itypi=itype(i,1)
12535         if (itypi.eq.ntyp1) cycle
12536         itypi1=itype(i+1,1)
12537         xi=c(1,nres+i)
12538         yi=c(2,nres+i)
12539         zi=c(3,nres+i)
12540 ! Change 12/1/95
12541         num_conti=0
12542 !
12543 ! Calculate SC interaction energy.
12544 !
12545         do iint=1,nint_gr(i)
12546 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12547 !d   &                  'iend=',iend(i,iint)
12548           do j=istart(i,iint),iend(i,iint)
12549             itypj=itype(j,1)
12550             if (itypj.eq.ntyp1) cycle
12551             xj=c(1,nres+j)-xi
12552             yj=c(2,nres+j)-yi
12553             zj=c(3,nres+j)-zi
12554 ! Change 12/1/95 to calculate four-body interactions
12555             rij=xj*xj+yj*yj+zj*zj
12556             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12557             if (sss.gt.0.0d0) then
12558               rrij=1.0D0/rij
12559               eps0ij=eps(itypi,itypj)
12560               fac=rrij**expon2
12561               e1=fac*fac*aa_aq(itypi,itypj)
12562               e2=fac*bb_aq(itypi,itypj)
12563               evdwij=e1+e2
12564               evdw=evdw+sss*evdwij
12565 !
12566 ! Calculate the components of the gradient in DC and X
12567 !
12568               fac=-rrij*(e1+evdwij)*sss
12569               gg(1)=xj*fac
12570               gg(2)=yj*fac
12571               gg(3)=zj*fac
12572               do k=1,3
12573                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12574                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12575                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12576                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12577               enddo
12578             endif
12579           enddo      ! j
12580         enddo        ! iint
12581       enddo          ! i
12582       do i=1,nct
12583         do j=1,3
12584           gvdwc(j,i)=expon*gvdwc(j,i)
12585           gvdwx(j,i)=expon*gvdwx(j,i)
12586         enddo
12587       enddo
12588 !******************************************************************************
12589 !
12590 !                              N O T E !!!
12591 !
12592 ! To save time, the factor of EXPON has been extracted from ALL components
12593 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12594 ! use!
12595 !
12596 !******************************************************************************
12597       return
12598       end subroutine elj_short
12599 !-----------------------------------------------------------------------------
12600       subroutine eljk_long(evdw)
12601 !
12602 ! This subroutine calculates the interaction energy of nonbonded side chains
12603 ! assuming the LJK potential of interaction.
12604 !
12605 !      implicit real*8 (a-h,o-z)
12606 !      include 'DIMENSIONS'
12607 !      include 'COMMON.GEO'
12608 !      include 'COMMON.VAR'
12609 !      include 'COMMON.LOCAL'
12610 !      include 'COMMON.CHAIN'
12611 !      include 'COMMON.DERIV'
12612 !      include 'COMMON.INTERACT'
12613 !      include 'COMMON.IOUNITS'
12614 !      include 'COMMON.NAMES'
12615       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12616       logical :: scheck
12617 !el local variables
12618       integer :: i,iint,j,k,itypi,itypi1,itypj
12619       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12620                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12621 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12622       evdw=0.0D0
12623       do i=iatsc_s,iatsc_e
12624         itypi=itype(i,1)
12625         if (itypi.eq.ntyp1) cycle
12626         itypi1=itype(i+1,1)
12627         xi=c(1,nres+i)
12628         yi=c(2,nres+i)
12629         zi=c(3,nres+i)
12630 !
12631 ! Calculate SC interaction energy.
12632 !
12633         do iint=1,nint_gr(i)
12634           do j=istart(i,iint),iend(i,iint)
12635             itypj=itype(j,1)
12636             if (itypj.eq.ntyp1) cycle
12637             xj=c(1,nres+j)-xi
12638             yj=c(2,nres+j)-yi
12639             zj=c(3,nres+j)-zi
12640             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12641             fac_augm=rrij**expon
12642             e_augm=augm(itypi,itypj)*fac_augm
12643             r_inv_ij=dsqrt(rrij)
12644             rij=1.0D0/r_inv_ij
12645             sss=sscale(rij/sigma(itypi,itypj))
12646             if (sss.lt.1.0d0) then
12647               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12648               fac=r_shift_inv**expon
12649               e1=fac*fac*aa_aq(itypi,itypj)
12650               e2=fac*bb_aq(itypi,itypj)
12651               evdwij=e_augm+e1+e2
12652 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12653 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12654 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12655 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12656 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12657 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12658 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12659               evdw=evdw+(1.0d0-sss)*evdwij
12660 !
12661 ! Calculate the components of the gradient in DC and X
12662 !
12663               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12664               fac=fac*(1.0d0-sss)
12665               gg(1)=xj*fac
12666               gg(2)=yj*fac
12667               gg(3)=zj*fac
12668               do k=1,3
12669                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12670                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12671                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12672                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12673               enddo
12674             endif
12675           enddo      ! j
12676         enddo        ! iint
12677       enddo          ! i
12678       do i=1,nct
12679         do j=1,3
12680           gvdwc(j,i)=expon*gvdwc(j,i)
12681           gvdwx(j,i)=expon*gvdwx(j,i)
12682         enddo
12683       enddo
12684       return
12685       end subroutine eljk_long
12686 !-----------------------------------------------------------------------------
12687       subroutine eljk_short(evdw)
12688 !
12689 ! This subroutine calculates the interaction energy of nonbonded side chains
12690 ! assuming the LJK potential of interaction.
12691 !
12692 !      implicit real*8 (a-h,o-z)
12693 !      include 'DIMENSIONS'
12694 !      include 'COMMON.GEO'
12695 !      include 'COMMON.VAR'
12696 !      include 'COMMON.LOCAL'
12697 !      include 'COMMON.CHAIN'
12698 !      include 'COMMON.DERIV'
12699 !      include 'COMMON.INTERACT'
12700 !      include 'COMMON.IOUNITS'
12701 !      include 'COMMON.NAMES'
12702       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12703       logical :: scheck
12704 !el local variables
12705       integer :: i,iint,j,k,itypi,itypi1,itypj
12706       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12707                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12708 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12709       evdw=0.0D0
12710       do i=iatsc_s,iatsc_e
12711         itypi=itype(i,1)
12712         if (itypi.eq.ntyp1) cycle
12713         itypi1=itype(i+1,1)
12714         xi=c(1,nres+i)
12715         yi=c(2,nres+i)
12716         zi=c(3,nres+i)
12717 !
12718 ! Calculate SC interaction energy.
12719 !
12720         do iint=1,nint_gr(i)
12721           do j=istart(i,iint),iend(i,iint)
12722             itypj=itype(j,1)
12723             if (itypj.eq.ntyp1) cycle
12724             xj=c(1,nres+j)-xi
12725             yj=c(2,nres+j)-yi
12726             zj=c(3,nres+j)-zi
12727             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12728             fac_augm=rrij**expon
12729             e_augm=augm(itypi,itypj)*fac_augm
12730             r_inv_ij=dsqrt(rrij)
12731             rij=1.0D0/r_inv_ij
12732             sss=sscale(rij/sigma(itypi,itypj))
12733             if (sss.gt.0.0d0) then
12734               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12735               fac=r_shift_inv**expon
12736               e1=fac*fac*aa_aq(itypi,itypj)
12737               e2=fac*bb_aq(itypi,itypj)
12738               evdwij=e_augm+e1+e2
12739 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12740 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12741 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12742 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12743 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12744 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12745 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12746               evdw=evdw+sss*evdwij
12747 !
12748 ! Calculate the components of the gradient in DC and X
12749 !
12750               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12751               fac=fac*sss
12752               gg(1)=xj*fac
12753               gg(2)=yj*fac
12754               gg(3)=zj*fac
12755               do k=1,3
12756                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12757                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12758                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12759                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12760               enddo
12761             endif
12762           enddo      ! j
12763         enddo        ! iint
12764       enddo          ! i
12765       do i=1,nct
12766         do j=1,3
12767           gvdwc(j,i)=expon*gvdwc(j,i)
12768           gvdwx(j,i)=expon*gvdwx(j,i)
12769         enddo
12770       enddo
12771       return
12772       end subroutine eljk_short
12773 !-----------------------------------------------------------------------------
12774       subroutine ebp_long(evdw)
12775 !
12776 ! This subroutine calculates the interaction energy of nonbonded side chains
12777 ! assuming the Berne-Pechukas potential of interaction.
12778 !
12779       use calc_data
12780 !      implicit real*8 (a-h,o-z)
12781 !      include 'DIMENSIONS'
12782 !      include 'COMMON.GEO'
12783 !      include 'COMMON.VAR'
12784 !      include 'COMMON.LOCAL'
12785 !      include 'COMMON.CHAIN'
12786 !      include 'COMMON.DERIV'
12787 !      include 'COMMON.NAMES'
12788 !      include 'COMMON.INTERACT'
12789 !      include 'COMMON.IOUNITS'
12790 !      include 'COMMON.CALC'
12791       use comm_srutu
12792 !el      integer :: icall
12793 !el      common /srutu/ icall
12794 !     double precision rrsave(maxdim)
12795       logical :: lprn
12796 !el local variables
12797       integer :: iint,itypi,itypi1,itypj
12798       real(kind=8) :: rrij,xi,yi,zi,fac
12799       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12800       evdw=0.0D0
12801 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12802       evdw=0.0D0
12803 !     if (icall.eq.0) then
12804 !       lprn=.true.
12805 !     else
12806         lprn=.false.
12807 !     endif
12808 !el      ind=0
12809       do i=iatsc_s,iatsc_e
12810         itypi=itype(i,1)
12811         if (itypi.eq.ntyp1) cycle
12812         itypi1=itype(i+1,1)
12813         xi=c(1,nres+i)
12814         yi=c(2,nres+i)
12815         zi=c(3,nres+i)
12816         dxi=dc_norm(1,nres+i)
12817         dyi=dc_norm(2,nres+i)
12818         dzi=dc_norm(3,nres+i)
12819 !        dsci_inv=dsc_inv(itypi)
12820         dsci_inv=vbld_inv(i+nres)
12821 !
12822 ! Calculate SC interaction energy.
12823 !
12824         do iint=1,nint_gr(i)
12825           do j=istart(i,iint),iend(i,iint)
12826 !el            ind=ind+1
12827             itypj=itype(j,1)
12828             if (itypj.eq.ntyp1) cycle
12829 !            dscj_inv=dsc_inv(itypj)
12830             dscj_inv=vbld_inv(j+nres)
12831             chi1=chi(itypi,itypj)
12832             chi2=chi(itypj,itypi)
12833             chi12=chi1*chi2
12834             chip1=chip(itypi)
12835             chip2=chip(itypj)
12836             chip12=chip1*chip2
12837             alf1=alp(itypi)
12838             alf2=alp(itypj)
12839             alf12=0.5D0*(alf1+alf2)
12840             xj=c(1,nres+j)-xi
12841             yj=c(2,nres+j)-yi
12842             zj=c(3,nres+j)-zi
12843             dxj=dc_norm(1,nres+j)
12844             dyj=dc_norm(2,nres+j)
12845             dzj=dc_norm(3,nres+j)
12846             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12847             rij=dsqrt(rrij)
12848             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12849
12850             if (sss.lt.1.0d0) then
12851
12852 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12853               call sc_angular
12854 ! Calculate whole angle-dependent part of epsilon and contributions
12855 ! to its derivatives
12856               fac=(rrij*sigsq)**expon2
12857               e1=fac*fac*aa_aq(itypi,itypj)
12858               e2=fac*bb_aq(itypi,itypj)
12859               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12860               eps2der=evdwij*eps3rt
12861               eps3der=evdwij*eps2rt
12862               evdwij=evdwij*eps2rt*eps3rt
12863               evdw=evdw+evdwij*(1.0d0-sss)
12864               if (lprn) then
12865               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12866               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12867 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12868 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12869 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12870 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12871 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12872 !d     &          evdwij
12873               endif
12874 ! Calculate gradient components.
12875               e1=e1*eps1*eps2rt**2*eps3rt**2
12876               fac=-expon*(e1+evdwij)
12877               sigder=fac/sigsq
12878               fac=rrij*fac
12879 ! Calculate radial part of the gradient
12880               gg(1)=xj*fac
12881               gg(2)=yj*fac
12882               gg(3)=zj*fac
12883 ! Calculate the angular part of the gradient and sum add the contributions
12884 ! to the appropriate components of the Cartesian gradient.
12885               call sc_grad_scale(1.0d0-sss)
12886             endif
12887           enddo      ! j
12888         enddo        ! iint
12889       enddo          ! i
12890 !     stop
12891       return
12892       end subroutine ebp_long
12893 !-----------------------------------------------------------------------------
12894       subroutine ebp_short(evdw)
12895 !
12896 ! This subroutine calculates the interaction energy of nonbonded side chains
12897 ! assuming the Berne-Pechukas potential of interaction.
12898 !
12899       use calc_data
12900 !      implicit real*8 (a-h,o-z)
12901 !      include 'DIMENSIONS'
12902 !      include 'COMMON.GEO'
12903 !      include 'COMMON.VAR'
12904 !      include 'COMMON.LOCAL'
12905 !      include 'COMMON.CHAIN'
12906 !      include 'COMMON.DERIV'
12907 !      include 'COMMON.NAMES'
12908 !      include 'COMMON.INTERACT'
12909 !      include 'COMMON.IOUNITS'
12910 !      include 'COMMON.CALC'
12911       use comm_srutu
12912 !el      integer :: icall
12913 !el      common /srutu/ icall
12914 !     double precision rrsave(maxdim)
12915       logical :: lprn
12916 !el local variables
12917       integer :: iint,itypi,itypi1,itypj
12918       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12919       real(kind=8) :: sss,e1,e2,evdw
12920       evdw=0.0D0
12921 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12922       evdw=0.0D0
12923 !     if (icall.eq.0) then
12924 !       lprn=.true.
12925 !     else
12926         lprn=.false.
12927 !     endif
12928 !el      ind=0
12929       do i=iatsc_s,iatsc_e
12930         itypi=itype(i,1)
12931         if (itypi.eq.ntyp1) cycle
12932         itypi1=itype(i+1,1)
12933         xi=c(1,nres+i)
12934         yi=c(2,nres+i)
12935         zi=c(3,nres+i)
12936         dxi=dc_norm(1,nres+i)
12937         dyi=dc_norm(2,nres+i)
12938         dzi=dc_norm(3,nres+i)
12939 !        dsci_inv=dsc_inv(itypi)
12940         dsci_inv=vbld_inv(i+nres)
12941 !
12942 ! Calculate SC interaction energy.
12943 !
12944         do iint=1,nint_gr(i)
12945           do j=istart(i,iint),iend(i,iint)
12946 !el            ind=ind+1
12947             itypj=itype(j,1)
12948             if (itypj.eq.ntyp1) cycle
12949 !            dscj_inv=dsc_inv(itypj)
12950             dscj_inv=vbld_inv(j+nres)
12951             chi1=chi(itypi,itypj)
12952             chi2=chi(itypj,itypi)
12953             chi12=chi1*chi2
12954             chip1=chip(itypi)
12955             chip2=chip(itypj)
12956             chip12=chip1*chip2
12957             alf1=alp(itypi)
12958             alf2=alp(itypj)
12959             alf12=0.5D0*(alf1+alf2)
12960             xj=c(1,nres+j)-xi
12961             yj=c(2,nres+j)-yi
12962             zj=c(3,nres+j)-zi
12963             dxj=dc_norm(1,nres+j)
12964             dyj=dc_norm(2,nres+j)
12965             dzj=dc_norm(3,nres+j)
12966             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12967             rij=dsqrt(rrij)
12968             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12969
12970             if (sss.gt.0.0d0) then
12971
12972 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12973               call sc_angular
12974 ! Calculate whole angle-dependent part of epsilon and contributions
12975 ! to its derivatives
12976               fac=(rrij*sigsq)**expon2
12977               e1=fac*fac*aa_aq(itypi,itypj)
12978               e2=fac*bb_aq(itypi,itypj)
12979               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12980               eps2der=evdwij*eps3rt
12981               eps3der=evdwij*eps2rt
12982               evdwij=evdwij*eps2rt*eps3rt
12983               evdw=evdw+evdwij*sss
12984               if (lprn) then
12985               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12986               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12987 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12988 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12989 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12990 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12991 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12992 !d     &          evdwij
12993               endif
12994 ! Calculate gradient components.
12995               e1=e1*eps1*eps2rt**2*eps3rt**2
12996               fac=-expon*(e1+evdwij)
12997               sigder=fac/sigsq
12998               fac=rrij*fac
12999 ! Calculate radial part of the gradient
13000               gg(1)=xj*fac
13001               gg(2)=yj*fac
13002               gg(3)=zj*fac
13003 ! Calculate the angular part of the gradient and sum add the contributions
13004 ! to the appropriate components of the Cartesian gradient.
13005               call sc_grad_scale(sss)
13006             endif
13007           enddo      ! j
13008         enddo        ! iint
13009       enddo          ! i
13010 !     stop
13011       return
13012       end subroutine ebp_short
13013 !-----------------------------------------------------------------------------
13014       subroutine egb_long(evdw)
13015 !
13016 ! This subroutine calculates the interaction energy of nonbonded side chains
13017 ! assuming the Gay-Berne potential of interaction.
13018 !
13019       use calc_data
13020 !      implicit real*8 (a-h,o-z)
13021 !      include 'DIMENSIONS'
13022 !      include 'COMMON.GEO'
13023 !      include 'COMMON.VAR'
13024 !      include 'COMMON.LOCAL'
13025 !      include 'COMMON.CHAIN'
13026 !      include 'COMMON.DERIV'
13027 !      include 'COMMON.NAMES'
13028 !      include 'COMMON.INTERACT'
13029 !      include 'COMMON.IOUNITS'
13030 !      include 'COMMON.CALC'
13031 !      include 'COMMON.CONTROL'
13032       logical :: lprn
13033 !el local variables
13034       integer :: iint,itypi,itypi1,itypj,subchap
13035       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13036       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13037       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13038                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13039                     ssgradlipi,ssgradlipj
13040
13041
13042       evdw=0.0D0
13043 !cccc      energy_dec=.false.
13044 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13045       evdw=0.0D0
13046       lprn=.false.
13047 !     if (icall.eq.0) lprn=.false.
13048 !el      ind=0
13049       do i=iatsc_s,iatsc_e
13050         itypi=itype(i,1)
13051         if (itypi.eq.ntyp1) cycle
13052         itypi1=itype(i+1,1)
13053         xi=c(1,nres+i)
13054         yi=c(2,nres+i)
13055         zi=c(3,nres+i)
13056           xi=mod(xi,boxxsize)
13057           if (xi.lt.0) xi=xi+boxxsize
13058           yi=mod(yi,boxysize)
13059           if (yi.lt.0) yi=yi+boxysize
13060           zi=mod(zi,boxzsize)
13061           if (zi.lt.0) zi=zi+boxzsize
13062        if ((zi.gt.bordlipbot)    &
13063         .and.(zi.lt.bordliptop)) then
13064 !C the energy transfer exist
13065         if (zi.lt.buflipbot) then
13066 !C what fraction I am in
13067          fracinbuf=1.0d0-    &
13068              ((zi-bordlipbot)/lipbufthick)
13069 !C lipbufthick is thickenes of lipid buffore
13070          sslipi=sscalelip(fracinbuf)
13071          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13072         elseif (zi.gt.bufliptop) then
13073          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13074          sslipi=sscalelip(fracinbuf)
13075          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13076         else
13077          sslipi=1.0d0
13078          ssgradlipi=0.0
13079         endif
13080        else
13081          sslipi=0.0d0
13082          ssgradlipi=0.0
13083        endif
13084
13085         dxi=dc_norm(1,nres+i)
13086         dyi=dc_norm(2,nres+i)
13087         dzi=dc_norm(3,nres+i)
13088 !        dsci_inv=dsc_inv(itypi)
13089         dsci_inv=vbld_inv(i+nres)
13090 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13091 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13092 !
13093 ! Calculate SC interaction energy.
13094 !
13095         do iint=1,nint_gr(i)
13096           do j=istart(i,iint),iend(i,iint)
13097             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13098 !              call dyn_ssbond_ene(i,j,evdwij)
13099 !              evdw=evdw+evdwij
13100 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13101 !                              'evdw',i,j,evdwij,' ss'
13102 !              if (energy_dec) write (iout,*) &
13103 !                              'evdw',i,j,evdwij,' ss'
13104 !             do k=j+1,iend(i,iint)
13105 !C search over all next residues
13106 !              if (dyn_ss_mask(k)) then
13107 !C check if they are cysteins
13108 !C              write(iout,*) 'k=',k
13109
13110 !c              write(iout,*) "PRZED TRI", evdwij
13111 !               evdwij_przed_tri=evdwij
13112 !              call triple_ssbond_ene(i,j,k,evdwij)
13113 !c               if(evdwij_przed_tri.ne.evdwij) then
13114 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13115 !c               endif
13116
13117 !c              write(iout,*) "PO TRI", evdwij
13118 !C call the energy function that removes the artifical triple disulfide
13119 !C bond the soubroutine is located in ssMD.F
13120 !              evdw=evdw+evdwij
13121               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13122                             'evdw',i,j,evdwij,'tss'
13123 !              endif!dyn_ss_mask(k)
13124 !             enddo! k
13125
13126             ELSE
13127 !el            ind=ind+1
13128             itypj=itype(j,1)
13129             if (itypj.eq.ntyp1) cycle
13130 !            dscj_inv=dsc_inv(itypj)
13131             dscj_inv=vbld_inv(j+nres)
13132 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13133 !     &       1.0d0/vbld(j+nres)
13134 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13135             sig0ij=sigma(itypi,itypj)
13136             chi1=chi(itypi,itypj)
13137             chi2=chi(itypj,itypi)
13138             chi12=chi1*chi2
13139             chip1=chip(itypi)
13140             chip2=chip(itypj)
13141             chip12=chip1*chip2
13142             alf1=alp(itypi)
13143             alf2=alp(itypj)
13144             alf12=0.5D0*(alf1+alf2)
13145             xj=c(1,nres+j)
13146             yj=c(2,nres+j)
13147             zj=c(3,nres+j)
13148 ! Searching for nearest neighbour
13149           xj=mod(xj,boxxsize)
13150           if (xj.lt.0) xj=xj+boxxsize
13151           yj=mod(yj,boxysize)
13152           if (yj.lt.0) yj=yj+boxysize
13153           zj=mod(zj,boxzsize)
13154           if (zj.lt.0) zj=zj+boxzsize
13155        if ((zj.gt.bordlipbot)   &
13156       .and.(zj.lt.bordliptop)) then
13157 !C the energy transfer exist
13158         if (zj.lt.buflipbot) then
13159 !C what fraction I am in
13160          fracinbuf=1.0d0-  &
13161              ((zj-bordlipbot)/lipbufthick)
13162 !C lipbufthick is thickenes of lipid buffore
13163          sslipj=sscalelip(fracinbuf)
13164          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13165         elseif (zj.gt.bufliptop) then
13166          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13167          sslipj=sscalelip(fracinbuf)
13168          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13169         else
13170          sslipj=1.0d0
13171          ssgradlipj=0.0
13172         endif
13173        else
13174          sslipj=0.0d0
13175          ssgradlipj=0.0
13176        endif
13177       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13178        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13179       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13180        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13181
13182           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13183           xj_safe=xj
13184           yj_safe=yj
13185           zj_safe=zj
13186           subchap=0
13187           do xshift=-1,1
13188           do yshift=-1,1
13189           do zshift=-1,1
13190           xj=xj_safe+xshift*boxxsize
13191           yj=yj_safe+yshift*boxysize
13192           zj=zj_safe+zshift*boxzsize
13193           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13194           if(dist_temp.lt.dist_init) then
13195             dist_init=dist_temp
13196             xj_temp=xj
13197             yj_temp=yj
13198             zj_temp=zj
13199             subchap=1
13200           endif
13201           enddo
13202           enddo
13203           enddo
13204           if (subchap.eq.1) then
13205           xj=xj_temp-xi
13206           yj=yj_temp-yi
13207           zj=zj_temp-zi
13208           else
13209           xj=xj_safe-xi
13210           yj=yj_safe-yi
13211           zj=zj_safe-zi
13212           endif
13213
13214             dxj=dc_norm(1,nres+j)
13215             dyj=dc_norm(2,nres+j)
13216             dzj=dc_norm(3,nres+j)
13217             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13218             rij=dsqrt(rrij)
13219             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13220             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13221             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13222             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13223             if (sss_ele_cut.le.0.0) cycle
13224             if (sss.lt.1.0d0) then
13225
13226 ! Calculate angle-dependent terms of energy and contributions to their
13227 ! derivatives.
13228               call sc_angular
13229               sigsq=1.0D0/sigsq
13230               sig=sig0ij*dsqrt(sigsq)
13231               rij_shift=1.0D0/rij-sig+sig0ij
13232 ! for diagnostics; uncomment
13233 !              rij_shift=1.2*sig0ij
13234 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13235               if (rij_shift.le.0.0D0) then
13236                 evdw=1.0D20
13237 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13238 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13239 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13240                 return
13241               endif
13242               sigder=-sig*sigsq
13243 !---------------------------------------------------------------
13244               rij_shift=1.0D0/rij_shift
13245               fac=rij_shift**expon
13246               e1=fac*fac*aa
13247               e2=fac*bb
13248               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13249               eps2der=evdwij*eps3rt
13250               eps3der=evdwij*eps2rt
13251 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13252 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13253               evdwij=evdwij*eps2rt*eps3rt
13254               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13255               if (lprn) then
13256               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13257               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13258               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13259                 restyp(itypi,1),i,restyp(itypj,1),j,&
13260                 epsi,sigm,chi1,chi2,chip1,chip2,&
13261                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13262                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13263                 evdwij
13264               endif
13265
13266               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13267                               'evdw',i,j,evdwij
13268 !              if (energy_dec) write (iout,*) &
13269 !                              'evdw',i,j,evdwij,"egb_long"
13270
13271 ! Calculate gradient components.
13272               e1=e1*eps1*eps2rt**2*eps3rt**2
13273               fac=-expon*(e1+evdwij)*rij_shift
13274               sigder=fac*sigder
13275               fac=rij*fac
13276               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13277             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13278             /sigmaii(itypi,itypj))
13279 !              fac=0.0d0
13280 ! Calculate the radial part of the gradient
13281               gg(1)=xj*fac
13282               gg(2)=yj*fac
13283               gg(3)=zj*fac
13284 ! Calculate angular part of the gradient.
13285               call sc_grad_scale(1.0d0-sss)
13286             ENDIF    !mask_dyn_ss
13287             endif
13288           enddo      ! j
13289         enddo        ! iint
13290       enddo          ! i
13291 !      write (iout,*) "Number of loop steps in EGB:",ind
13292 !ccc      energy_dec=.false.
13293       return
13294       end subroutine egb_long
13295 !-----------------------------------------------------------------------------
13296       subroutine egb_short(evdw)
13297 !
13298 ! This subroutine calculates the interaction energy of nonbonded side chains
13299 ! assuming the Gay-Berne potential of interaction.
13300 !
13301       use calc_data
13302 !      implicit real*8 (a-h,o-z)
13303 !      include 'DIMENSIONS'
13304 !      include 'COMMON.GEO'
13305 !      include 'COMMON.VAR'
13306 !      include 'COMMON.LOCAL'
13307 !      include 'COMMON.CHAIN'
13308 !      include 'COMMON.DERIV'
13309 !      include 'COMMON.NAMES'
13310 !      include 'COMMON.INTERACT'
13311 !      include 'COMMON.IOUNITS'
13312 !      include 'COMMON.CALC'
13313 !      include 'COMMON.CONTROL'
13314       logical :: lprn
13315 !el local variables
13316       integer :: iint,itypi,itypi1,itypj,subchap
13317       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13318       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13319       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13320                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13321                     ssgradlipi,ssgradlipj
13322       evdw=0.0D0
13323 !cccc      energy_dec=.false.
13324 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13325       evdw=0.0D0
13326       lprn=.false.
13327 !     if (icall.eq.0) lprn=.false.
13328 !el      ind=0
13329       do i=iatsc_s,iatsc_e
13330         itypi=itype(i,1)
13331         if (itypi.eq.ntyp1) cycle
13332         itypi1=itype(i+1,1)
13333         xi=c(1,nres+i)
13334         yi=c(2,nres+i)
13335         zi=c(3,nres+i)
13336           xi=mod(xi,boxxsize)
13337           if (xi.lt.0) xi=xi+boxxsize
13338           yi=mod(yi,boxysize)
13339           if (yi.lt.0) yi=yi+boxysize
13340           zi=mod(zi,boxzsize)
13341           if (zi.lt.0) zi=zi+boxzsize
13342        if ((zi.gt.bordlipbot)    &
13343         .and.(zi.lt.bordliptop)) then
13344 !C the energy transfer exist
13345         if (zi.lt.buflipbot) then
13346 !C what fraction I am in
13347          fracinbuf=1.0d0-    &
13348              ((zi-bordlipbot)/lipbufthick)
13349 !C lipbufthick is thickenes of lipid buffore
13350          sslipi=sscalelip(fracinbuf)
13351          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13352         elseif (zi.gt.bufliptop) then
13353          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13354          sslipi=sscalelip(fracinbuf)
13355          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13356         else
13357          sslipi=1.0d0
13358          ssgradlipi=0.0
13359         endif
13360        else
13361          sslipi=0.0d0
13362          ssgradlipi=0.0
13363        endif
13364
13365         dxi=dc_norm(1,nres+i)
13366         dyi=dc_norm(2,nres+i)
13367         dzi=dc_norm(3,nres+i)
13368 !        dsci_inv=dsc_inv(itypi)
13369         dsci_inv=vbld_inv(i+nres)
13370
13371         dxi=dc_norm(1,nres+i)
13372         dyi=dc_norm(2,nres+i)
13373         dzi=dc_norm(3,nres+i)
13374 !        dsci_inv=dsc_inv(itypi)
13375         dsci_inv=vbld_inv(i+nres)
13376 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13377 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13378 !
13379 ! Calculate SC interaction energy.
13380 !
13381         do iint=1,nint_gr(i)
13382           do j=istart(i,iint),iend(i,iint)
13383             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13384               call dyn_ssbond_ene(i,j,evdwij)
13385               evdw=evdw+evdwij
13386               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13387                               'evdw',i,j,evdwij,' ss'
13388              do k=j+1,iend(i,iint)
13389 !C search over all next residues
13390               if (dyn_ss_mask(k)) then
13391 !C check if they are cysteins
13392 !C              write(iout,*) 'k=',k
13393
13394 !c              write(iout,*) "PRZED TRI", evdwij
13395 !               evdwij_przed_tri=evdwij
13396               call triple_ssbond_ene(i,j,k,evdwij)
13397 !c               if(evdwij_przed_tri.ne.evdwij) then
13398 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13399 !c               endif
13400
13401 !c              write(iout,*) "PO TRI", evdwij
13402 !C call the energy function that removes the artifical triple disulfide
13403 !C bond the soubroutine is located in ssMD.F
13404               evdw=evdw+evdwij
13405               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13406                             'evdw',i,j,evdwij,'tss'
13407               endif!dyn_ss_mask(k)
13408              enddo! k
13409
13410 !              if (energy_dec) write (iout,*) &
13411 !                              'evdw',i,j,evdwij,' ss'
13412             ELSE
13413 !el            ind=ind+1
13414             itypj=itype(j,1)
13415             if (itypj.eq.ntyp1) cycle
13416 !            dscj_inv=dsc_inv(itypj)
13417             dscj_inv=vbld_inv(j+nres)
13418 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13419 !     &       1.0d0/vbld(j+nres)
13420 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13421             sig0ij=sigma(itypi,itypj)
13422             chi1=chi(itypi,itypj)
13423             chi2=chi(itypj,itypi)
13424             chi12=chi1*chi2
13425             chip1=chip(itypi)
13426             chip2=chip(itypj)
13427             chip12=chip1*chip2
13428             alf1=alp(itypi)
13429             alf2=alp(itypj)
13430             alf12=0.5D0*(alf1+alf2)
13431 !            xj=c(1,nres+j)-xi
13432 !            yj=c(2,nres+j)-yi
13433 !            zj=c(3,nres+j)-zi
13434             xj=c(1,nres+j)
13435             yj=c(2,nres+j)
13436             zj=c(3,nres+j)
13437 ! Searching for nearest neighbour
13438           xj=mod(xj,boxxsize)
13439           if (xj.lt.0) xj=xj+boxxsize
13440           yj=mod(yj,boxysize)
13441           if (yj.lt.0) yj=yj+boxysize
13442           zj=mod(zj,boxzsize)
13443           if (zj.lt.0) zj=zj+boxzsize
13444        if ((zj.gt.bordlipbot)   &
13445       .and.(zj.lt.bordliptop)) then
13446 !C the energy transfer exist
13447         if (zj.lt.buflipbot) then
13448 !C what fraction I am in
13449          fracinbuf=1.0d0-  &
13450              ((zj-bordlipbot)/lipbufthick)
13451 !C lipbufthick is thickenes of lipid buffore
13452          sslipj=sscalelip(fracinbuf)
13453          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13454         elseif (zj.gt.bufliptop) then
13455          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13456          sslipj=sscalelip(fracinbuf)
13457          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13458         else
13459          sslipj=1.0d0
13460          ssgradlipj=0.0
13461         endif
13462        else
13463          sslipj=0.0d0
13464          ssgradlipj=0.0
13465        endif
13466       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13467        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13468       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13469        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13470
13471           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13472           xj_safe=xj
13473           yj_safe=yj
13474           zj_safe=zj
13475           subchap=0
13476
13477           do xshift=-1,1
13478           do yshift=-1,1
13479           do zshift=-1,1
13480           xj=xj_safe+xshift*boxxsize
13481           yj=yj_safe+yshift*boxysize
13482           zj=zj_safe+zshift*boxzsize
13483           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13484           if(dist_temp.lt.dist_init) then
13485             dist_init=dist_temp
13486             xj_temp=xj
13487             yj_temp=yj
13488             zj_temp=zj
13489             subchap=1
13490           endif
13491           enddo
13492           enddo
13493           enddo
13494           if (subchap.eq.1) then
13495           xj=xj_temp-xi
13496           yj=yj_temp-yi
13497           zj=zj_temp-zi
13498           else
13499           xj=xj_safe-xi
13500           yj=yj_safe-yi
13501           zj=zj_safe-zi
13502           endif
13503
13504             dxj=dc_norm(1,nres+j)
13505             dyj=dc_norm(2,nres+j)
13506             dzj=dc_norm(3,nres+j)
13507             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13508             rij=dsqrt(rrij)
13509             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13510             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13511             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13512             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13513             if (sss_ele_cut.le.0.0) cycle
13514
13515             if (sss.gt.0.0d0) then
13516
13517 ! Calculate angle-dependent terms of energy and contributions to their
13518 ! derivatives.
13519               call sc_angular
13520               sigsq=1.0D0/sigsq
13521               sig=sig0ij*dsqrt(sigsq)
13522               rij_shift=1.0D0/rij-sig+sig0ij
13523 ! for diagnostics; uncomment
13524 !              rij_shift=1.2*sig0ij
13525 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13526               if (rij_shift.le.0.0D0) then
13527                 evdw=1.0D20
13528 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13529 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13530 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13531                 return
13532               endif
13533               sigder=-sig*sigsq
13534 !---------------------------------------------------------------
13535               rij_shift=1.0D0/rij_shift
13536               fac=rij_shift**expon
13537               e1=fac*fac*aa
13538               e2=fac*bb
13539               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13540               eps2der=evdwij*eps3rt
13541               eps3der=evdwij*eps2rt
13542 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13543 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13544               evdwij=evdwij*eps2rt*eps3rt
13545               evdw=evdw+evdwij*sss*sss_ele_cut
13546               if (lprn) then
13547               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13548               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13549               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13550                 restyp(itypi,1),i,restyp(itypj,1),j,&
13551                 epsi,sigm,chi1,chi2,chip1,chip2,&
13552                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13553                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13554                 evdwij
13555               endif
13556
13557               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13558                               'evdw',i,j,evdwij
13559 !              if (energy_dec) write (iout,*) &
13560 !                              'evdw',i,j,evdwij,"egb_short"
13561
13562 ! Calculate gradient components.
13563               e1=e1*eps1*eps2rt**2*eps3rt**2
13564               fac=-expon*(e1+evdwij)*rij_shift
13565               sigder=fac*sigder
13566               fac=rij*fac
13567               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13568             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13569             /sigmaii(itypi,itypj))
13570
13571 !              fac=0.0d0
13572 ! Calculate the radial part of the gradient
13573               gg(1)=xj*fac
13574               gg(2)=yj*fac
13575               gg(3)=zj*fac
13576 ! Calculate angular part of the gradient.
13577               call sc_grad_scale(sss)
13578             endif
13579           ENDIF !mask_dyn_ss
13580           enddo      ! j
13581         enddo        ! iint
13582       enddo          ! i
13583 !      write (iout,*) "Number of loop steps in EGB:",ind
13584 !ccc      energy_dec=.false.
13585       return
13586       end subroutine egb_short
13587 !-----------------------------------------------------------------------------
13588       subroutine egbv_long(evdw)
13589 !
13590 ! This subroutine calculates the interaction energy of nonbonded side chains
13591 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13592 !
13593       use calc_data
13594 !      implicit real*8 (a-h,o-z)
13595 !      include 'DIMENSIONS'
13596 !      include 'COMMON.GEO'
13597 !      include 'COMMON.VAR'
13598 !      include 'COMMON.LOCAL'
13599 !      include 'COMMON.CHAIN'
13600 !      include 'COMMON.DERIV'
13601 !      include 'COMMON.NAMES'
13602 !      include 'COMMON.INTERACT'
13603 !      include 'COMMON.IOUNITS'
13604 !      include 'COMMON.CALC'
13605       use comm_srutu
13606 !el      integer :: icall
13607 !el      common /srutu/ icall
13608       logical :: lprn
13609 !el local variables
13610       integer :: iint,itypi,itypi1,itypj
13611       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13612       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13613       evdw=0.0D0
13614 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13615       evdw=0.0D0
13616       lprn=.false.
13617 !     if (icall.eq.0) lprn=.true.
13618 !el      ind=0
13619       do i=iatsc_s,iatsc_e
13620         itypi=itype(i,1)
13621         if (itypi.eq.ntyp1) cycle
13622         itypi1=itype(i+1,1)
13623         xi=c(1,nres+i)
13624         yi=c(2,nres+i)
13625         zi=c(3,nres+i)
13626         dxi=dc_norm(1,nres+i)
13627         dyi=dc_norm(2,nres+i)
13628         dzi=dc_norm(3,nres+i)
13629 !        dsci_inv=dsc_inv(itypi)
13630         dsci_inv=vbld_inv(i+nres)
13631 !
13632 ! Calculate SC interaction energy.
13633 !
13634         do iint=1,nint_gr(i)
13635           do j=istart(i,iint),iend(i,iint)
13636 !el            ind=ind+1
13637             itypj=itype(j,1)
13638             if (itypj.eq.ntyp1) cycle
13639 !            dscj_inv=dsc_inv(itypj)
13640             dscj_inv=vbld_inv(j+nres)
13641             sig0ij=sigma(itypi,itypj)
13642             r0ij=r0(itypi,itypj)
13643             chi1=chi(itypi,itypj)
13644             chi2=chi(itypj,itypi)
13645             chi12=chi1*chi2
13646             chip1=chip(itypi)
13647             chip2=chip(itypj)
13648             chip12=chip1*chip2
13649             alf1=alp(itypi)
13650             alf2=alp(itypj)
13651             alf12=0.5D0*(alf1+alf2)
13652             xj=c(1,nres+j)-xi
13653             yj=c(2,nres+j)-yi
13654             zj=c(3,nres+j)-zi
13655             dxj=dc_norm(1,nres+j)
13656             dyj=dc_norm(2,nres+j)
13657             dzj=dc_norm(3,nres+j)
13658             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13659             rij=dsqrt(rrij)
13660
13661             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13662
13663             if (sss.lt.1.0d0) then
13664
13665 ! Calculate angle-dependent terms of energy and contributions to their
13666 ! derivatives.
13667               call sc_angular
13668               sigsq=1.0D0/sigsq
13669               sig=sig0ij*dsqrt(sigsq)
13670               rij_shift=1.0D0/rij-sig+r0ij
13671 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13672               if (rij_shift.le.0.0D0) then
13673                 evdw=1.0D20
13674                 return
13675               endif
13676               sigder=-sig*sigsq
13677 !---------------------------------------------------------------
13678               rij_shift=1.0D0/rij_shift
13679               fac=rij_shift**expon
13680               e1=fac*fac*aa_aq(itypi,itypj)
13681               e2=fac*bb_aq(itypi,itypj)
13682               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13683               eps2der=evdwij*eps3rt
13684               eps3der=evdwij*eps2rt
13685               fac_augm=rrij**expon
13686               e_augm=augm(itypi,itypj)*fac_augm
13687               evdwij=evdwij*eps2rt*eps3rt
13688               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13689               if (lprn) then
13690               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13691               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13692               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13693                 restyp(itypi,1),i,restyp(itypj,1),j,&
13694                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13695                 chi1,chi2,chip1,chip2,&
13696                 eps1,eps2rt**2,eps3rt**2,&
13697                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13698                 evdwij+e_augm
13699               endif
13700 ! Calculate gradient components.
13701               e1=e1*eps1*eps2rt**2*eps3rt**2
13702               fac=-expon*(e1+evdwij)*rij_shift
13703               sigder=fac*sigder
13704               fac=rij*fac-2*expon*rrij*e_augm
13705 ! Calculate the radial part of the gradient
13706               gg(1)=xj*fac
13707               gg(2)=yj*fac
13708               gg(3)=zj*fac
13709 ! Calculate angular part of the gradient.
13710               call sc_grad_scale(1.0d0-sss)
13711             endif
13712           enddo      ! j
13713         enddo        ! iint
13714       enddo          ! i
13715       end subroutine egbv_long
13716 !-----------------------------------------------------------------------------
13717       subroutine egbv_short(evdw)
13718 !
13719 ! This subroutine calculates the interaction energy of nonbonded side chains
13720 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13721 !
13722       use calc_data
13723 !      implicit real*8 (a-h,o-z)
13724 !      include 'DIMENSIONS'
13725 !      include 'COMMON.GEO'
13726 !      include 'COMMON.VAR'
13727 !      include 'COMMON.LOCAL'
13728 !      include 'COMMON.CHAIN'
13729 !      include 'COMMON.DERIV'
13730 !      include 'COMMON.NAMES'
13731 !      include 'COMMON.INTERACT'
13732 !      include 'COMMON.IOUNITS'
13733 !      include 'COMMON.CALC'
13734       use comm_srutu
13735 !el      integer :: icall
13736 !el      common /srutu/ icall
13737       logical :: lprn
13738 !el local variables
13739       integer :: iint,itypi,itypi1,itypj
13740       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13741       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13742       evdw=0.0D0
13743 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13744       evdw=0.0D0
13745       lprn=.false.
13746 !     if (icall.eq.0) lprn=.true.
13747 !el      ind=0
13748       do i=iatsc_s,iatsc_e
13749         itypi=itype(i,1)
13750         if (itypi.eq.ntyp1) cycle
13751         itypi1=itype(i+1,1)
13752         xi=c(1,nres+i)
13753         yi=c(2,nres+i)
13754         zi=c(3,nres+i)
13755         dxi=dc_norm(1,nres+i)
13756         dyi=dc_norm(2,nres+i)
13757         dzi=dc_norm(3,nres+i)
13758 !        dsci_inv=dsc_inv(itypi)
13759         dsci_inv=vbld_inv(i+nres)
13760 !
13761 ! Calculate SC interaction energy.
13762 !
13763         do iint=1,nint_gr(i)
13764           do j=istart(i,iint),iend(i,iint)
13765 !el            ind=ind+1
13766             itypj=itype(j,1)
13767             if (itypj.eq.ntyp1) cycle
13768 !            dscj_inv=dsc_inv(itypj)
13769             dscj_inv=vbld_inv(j+nres)
13770             sig0ij=sigma(itypi,itypj)
13771             r0ij=r0(itypi,itypj)
13772             chi1=chi(itypi,itypj)
13773             chi2=chi(itypj,itypi)
13774             chi12=chi1*chi2
13775             chip1=chip(itypi)
13776             chip2=chip(itypj)
13777             chip12=chip1*chip2
13778             alf1=alp(itypi)
13779             alf2=alp(itypj)
13780             alf12=0.5D0*(alf1+alf2)
13781             xj=c(1,nres+j)-xi
13782             yj=c(2,nres+j)-yi
13783             zj=c(3,nres+j)-zi
13784             dxj=dc_norm(1,nres+j)
13785             dyj=dc_norm(2,nres+j)
13786             dzj=dc_norm(3,nres+j)
13787             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13788             rij=dsqrt(rrij)
13789
13790             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13791
13792             if (sss.gt.0.0d0) then
13793
13794 ! Calculate angle-dependent terms of energy and contributions to their
13795 ! derivatives.
13796               call sc_angular
13797               sigsq=1.0D0/sigsq
13798               sig=sig0ij*dsqrt(sigsq)
13799               rij_shift=1.0D0/rij-sig+r0ij
13800 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13801               if (rij_shift.le.0.0D0) then
13802                 evdw=1.0D20
13803                 return
13804               endif
13805               sigder=-sig*sigsq
13806 !---------------------------------------------------------------
13807               rij_shift=1.0D0/rij_shift
13808               fac=rij_shift**expon
13809               e1=fac*fac*aa_aq(itypi,itypj)
13810               e2=fac*bb_aq(itypi,itypj)
13811               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13812               eps2der=evdwij*eps3rt
13813               eps3der=evdwij*eps2rt
13814               fac_augm=rrij**expon
13815               e_augm=augm(itypi,itypj)*fac_augm
13816               evdwij=evdwij*eps2rt*eps3rt
13817               evdw=evdw+(evdwij+e_augm)*sss
13818               if (lprn) then
13819               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13820               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13821               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13822                 restyp(itypi,1),i,restyp(itypj,1),j,&
13823                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13824                 chi1,chi2,chip1,chip2,&
13825                 eps1,eps2rt**2,eps3rt**2,&
13826                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13827                 evdwij+e_augm
13828               endif
13829 ! Calculate gradient components.
13830               e1=e1*eps1*eps2rt**2*eps3rt**2
13831               fac=-expon*(e1+evdwij)*rij_shift
13832               sigder=fac*sigder
13833               fac=rij*fac-2*expon*rrij*e_augm
13834 ! Calculate the radial part of the gradient
13835               gg(1)=xj*fac
13836               gg(2)=yj*fac
13837               gg(3)=zj*fac
13838 ! Calculate angular part of the gradient.
13839               call sc_grad_scale(sss)
13840             endif
13841           enddo      ! j
13842         enddo        ! iint
13843       enddo          ! i
13844       end subroutine egbv_short
13845 !-----------------------------------------------------------------------------
13846       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13847 !
13848 ! This subroutine calculates the average interaction energy and its gradient
13849 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13850 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13851 ! The potential depends both on the distance of peptide-group centers and on
13852 ! the orientation of the CA-CA virtual bonds.
13853 !
13854 !      implicit real*8 (a-h,o-z)
13855
13856       use comm_locel
13857 #ifdef MPI
13858       include 'mpif.h'
13859 #endif
13860 !      include 'DIMENSIONS'
13861 !      include 'COMMON.CONTROL'
13862 !      include 'COMMON.SETUP'
13863 !      include 'COMMON.IOUNITS'
13864 !      include 'COMMON.GEO'
13865 !      include 'COMMON.VAR'
13866 !      include 'COMMON.LOCAL'
13867 !      include 'COMMON.CHAIN'
13868 !      include 'COMMON.DERIV'
13869 !      include 'COMMON.INTERACT'
13870 !      include 'COMMON.CONTACTS'
13871 !      include 'COMMON.TORSION'
13872 !      include 'COMMON.VECTORS'
13873 !      include 'COMMON.FFIELD'
13874 !      include 'COMMON.TIME1'
13875       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13876       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13877       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13878 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13879       real(kind=8),dimension(4) :: muij
13880 !el      integer :: num_conti,j1,j2
13881 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13882 !el                   dz_normi,xmedi,ymedi,zmedi
13883 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13884 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13885 !el          num_conti,j1,j2
13886 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13887 #ifdef MOMENT
13888       real(kind=8) :: scal_el=1.0d0
13889 #else
13890       real(kind=8) :: scal_el=0.5d0
13891 #endif
13892 ! 12/13/98
13893 ! 13-go grudnia roku pamietnego...
13894       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13895                                              0.0d0,1.0d0,0.0d0,&
13896                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13897 !el local variables
13898       integer :: i,j,k
13899       real(kind=8) :: fac
13900       real(kind=8) :: dxj,dyj,dzj
13901       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13902
13903 !      allocate(num_cont_hb(nres)) !(maxres)
13904 !d      write(iout,*) 'In EELEC'
13905 !d      do i=1,nloctyp
13906 !d        write(iout,*) 'Type',i
13907 !d        write(iout,*) 'B1',B1(:,i)
13908 !d        write(iout,*) 'B2',B2(:,i)
13909 !d        write(iout,*) 'CC',CC(:,:,i)
13910 !d        write(iout,*) 'DD',DD(:,:,i)
13911 !d        write(iout,*) 'EE',EE(:,:,i)
13912 !d      enddo
13913 !d      call check_vecgrad
13914 !d      stop
13915       if (icheckgrad.eq.1) then
13916         do i=1,nres-1
13917           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13918           do k=1,3
13919             dc_norm(k,i)=dc(k,i)*fac
13920           enddo
13921 !          write (iout,*) 'i',i,' fac',fac
13922         enddo
13923       endif
13924       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13925           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13926           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13927 !        call vec_and_deriv
13928 #ifdef TIMING
13929         time01=MPI_Wtime()
13930 #endif
13931 !        print *, "before set matrices"
13932         call set_matrices
13933 !        print *,"after set martices"
13934 #ifdef TIMING
13935         time_mat=time_mat+MPI_Wtime()-time01
13936 #endif
13937       endif
13938 !d      do i=1,nres-1
13939 !d        write (iout,*) 'i=',i
13940 !d        do k=1,3
13941 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
13942 !d        enddo
13943 !d        do k=1,3
13944 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
13945 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
13946 !d        enddo
13947 !d      enddo
13948       t_eelecij=0.0d0
13949       ees=0.0D0
13950       evdw1=0.0D0
13951       eel_loc=0.0d0
13952       eello_turn3=0.0d0
13953       eello_turn4=0.0d0
13954 !el      ind=0
13955       do i=1,nres
13956         num_cont_hb(i)=0
13957       enddo
13958 !d      print '(a)','Enter EELEC'
13959 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
13960 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13961 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13962       do i=1,nres
13963         gel_loc_loc(i)=0.0d0
13964         gcorr_loc(i)=0.0d0
13965       enddo
13966 !
13967 !
13968 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
13969 !
13970 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
13971 !
13972       do i=iturn3_start,iturn3_end
13973         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
13974         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
13975         dxi=dc(1,i)
13976         dyi=dc(2,i)
13977         dzi=dc(3,i)
13978         dx_normi=dc_norm(1,i)
13979         dy_normi=dc_norm(2,i)
13980         dz_normi=dc_norm(3,i)
13981         xmedi=c(1,i)+0.5d0*dxi
13982         ymedi=c(2,i)+0.5d0*dyi
13983         zmedi=c(3,i)+0.5d0*dzi
13984           xmedi=dmod(xmedi,boxxsize)
13985           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13986           ymedi=dmod(ymedi,boxysize)
13987           if (ymedi.lt.0) ymedi=ymedi+boxysize
13988           zmedi=dmod(zmedi,boxzsize)
13989           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13990         num_conti=0
13991         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
13992         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
13993         num_cont_hb(i)=num_conti
13994       enddo
13995       do i=iturn4_start,iturn4_end
13996         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
13997           .or. itype(i+3,1).eq.ntyp1 &
13998           .or. itype(i+4,1).eq.ntyp1) cycle
13999         dxi=dc(1,i)
14000         dyi=dc(2,i)
14001         dzi=dc(3,i)
14002         dx_normi=dc_norm(1,i)
14003         dy_normi=dc_norm(2,i)
14004         dz_normi=dc_norm(3,i)
14005         xmedi=c(1,i)+0.5d0*dxi
14006         ymedi=c(2,i)+0.5d0*dyi
14007         zmedi=c(3,i)+0.5d0*dzi
14008           xmedi=dmod(xmedi,boxxsize)
14009           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14010           ymedi=dmod(ymedi,boxysize)
14011           if (ymedi.lt.0) ymedi=ymedi+boxysize
14012           zmedi=dmod(zmedi,boxzsize)
14013           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14014         num_conti=num_cont_hb(i)
14015         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14016         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14017           call eturn4(i,eello_turn4)
14018         num_cont_hb(i)=num_conti
14019       enddo   ! i
14020 !
14021 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14022 !
14023       do i=iatel_s,iatel_e
14024         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14025         dxi=dc(1,i)
14026         dyi=dc(2,i)
14027         dzi=dc(3,i)
14028         dx_normi=dc_norm(1,i)
14029         dy_normi=dc_norm(2,i)
14030         dz_normi=dc_norm(3,i)
14031         xmedi=c(1,i)+0.5d0*dxi
14032         ymedi=c(2,i)+0.5d0*dyi
14033         zmedi=c(3,i)+0.5d0*dzi
14034           xmedi=dmod(xmedi,boxxsize)
14035           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14036           ymedi=dmod(ymedi,boxysize)
14037           if (ymedi.lt.0) ymedi=ymedi+boxysize
14038           zmedi=dmod(zmedi,boxzsize)
14039           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14040 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14041         num_conti=num_cont_hb(i)
14042         do j=ielstart(i),ielend(i)
14043           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14044           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14045         enddo ! j
14046         num_cont_hb(i)=num_conti
14047       enddo   ! i
14048 !      write (iout,*) "Number of loop steps in EELEC:",ind
14049 !d      do i=1,nres
14050 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14051 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14052 !d      enddo
14053 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14054 !cc      eel_loc=eel_loc+eello_turn3
14055 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14056       return
14057       end subroutine eelec_scale
14058 !-----------------------------------------------------------------------------
14059       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14060 !      implicit real*8 (a-h,o-z)
14061
14062       use comm_locel
14063 !      include 'DIMENSIONS'
14064 #ifdef MPI
14065       include "mpif.h"
14066 #endif
14067 !      include 'COMMON.CONTROL'
14068 !      include 'COMMON.IOUNITS'
14069 !      include 'COMMON.GEO'
14070 !      include 'COMMON.VAR'
14071 !      include 'COMMON.LOCAL'
14072 !      include 'COMMON.CHAIN'
14073 !      include 'COMMON.DERIV'
14074 !      include 'COMMON.INTERACT'
14075 !      include 'COMMON.CONTACTS'
14076 !      include 'COMMON.TORSION'
14077 !      include 'COMMON.VECTORS'
14078 !      include 'COMMON.FFIELD'
14079 !      include 'COMMON.TIME1'
14080       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14081       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14082       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14083 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14084       real(kind=8),dimension(4) :: muij
14085       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14086                     dist_temp, dist_init,sss_grad
14087       integer xshift,yshift,zshift
14088
14089 !el      integer :: num_conti,j1,j2
14090 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14091 !el                   dz_normi,xmedi,ymedi,zmedi
14092 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14093 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14094 !el          num_conti,j1,j2
14095 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14096 #ifdef MOMENT
14097       real(kind=8) :: scal_el=1.0d0
14098 #else
14099       real(kind=8) :: scal_el=0.5d0
14100 #endif
14101 ! 12/13/98
14102 ! 13-go grudnia roku pamietnego...
14103       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14104                                              0.0d0,1.0d0,0.0d0,&
14105                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14106 !el local variables
14107       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14108       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14109       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14110       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14111       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14112       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14113       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14114                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14115                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14116                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14117                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14118                   ecosam,ecosbm,ecosgm,ghalf,time00
14119 !      integer :: maxconts
14120 !      maxconts = nres/4
14121 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14122 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14123 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14124 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14125 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14126 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14127 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14128 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14129 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14130 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14131 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14132 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14133 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14134
14135 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14136 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14137
14138 #ifdef MPI
14139           time00=MPI_Wtime()
14140 #endif
14141 !d      write (iout,*) "eelecij",i,j
14142 !el          ind=ind+1
14143           iteli=itel(i)
14144           itelj=itel(j)
14145           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14146           aaa=app(iteli,itelj)
14147           bbb=bpp(iteli,itelj)
14148           ael6i=ael6(iteli,itelj)
14149           ael3i=ael3(iteli,itelj)
14150           dxj=dc(1,j)
14151           dyj=dc(2,j)
14152           dzj=dc(3,j)
14153           dx_normj=dc_norm(1,j)
14154           dy_normj=dc_norm(2,j)
14155           dz_normj=dc_norm(3,j)
14156 !          xj=c(1,j)+0.5D0*dxj-xmedi
14157 !          yj=c(2,j)+0.5D0*dyj-ymedi
14158 !          zj=c(3,j)+0.5D0*dzj-zmedi
14159           xj=c(1,j)+0.5D0*dxj
14160           yj=c(2,j)+0.5D0*dyj
14161           zj=c(3,j)+0.5D0*dzj
14162           xj=mod(xj,boxxsize)
14163           if (xj.lt.0) xj=xj+boxxsize
14164           yj=mod(yj,boxysize)
14165           if (yj.lt.0) yj=yj+boxysize
14166           zj=mod(zj,boxzsize)
14167           if (zj.lt.0) zj=zj+boxzsize
14168       isubchap=0
14169       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14170       xj_safe=xj
14171       yj_safe=yj
14172       zj_safe=zj
14173       do xshift=-1,1
14174       do yshift=-1,1
14175       do zshift=-1,1
14176           xj=xj_safe+xshift*boxxsize
14177           yj=yj_safe+yshift*boxysize
14178           zj=zj_safe+zshift*boxzsize
14179           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14180           if(dist_temp.lt.dist_init) then
14181             dist_init=dist_temp
14182             xj_temp=xj
14183             yj_temp=yj
14184             zj_temp=zj
14185             isubchap=1
14186           endif
14187        enddo
14188        enddo
14189        enddo
14190        if (isubchap.eq.1) then
14191 !C          print *,i,j
14192           xj=xj_temp-xmedi
14193           yj=yj_temp-ymedi
14194           zj=zj_temp-zmedi
14195        else
14196           xj=xj_safe-xmedi
14197           yj=yj_safe-ymedi
14198           zj=zj_safe-zmedi
14199        endif
14200
14201           rij=xj*xj+yj*yj+zj*zj
14202           rrmij=1.0D0/rij
14203           rij=dsqrt(rij)
14204           rmij=1.0D0/rij
14205 ! For extracting the short-range part of Evdwpp
14206           sss=sscale(rij/rpp(iteli,itelj))
14207             sss_ele_cut=sscale_ele(rij)
14208             sss_ele_grad=sscagrad_ele(rij)
14209             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14210 !             sss_ele_cut=1.0d0
14211 !             sss_ele_grad=0.0d0
14212             if (sss_ele_cut.le.0.0) go to 128
14213
14214           r3ij=rrmij*rmij
14215           r6ij=r3ij*r3ij
14216           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14217           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14218           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14219           fac=cosa-3.0D0*cosb*cosg
14220           ev1=aaa*r6ij*r6ij
14221 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14222           if (j.eq.i+2) ev1=scal_el*ev1
14223           ev2=bbb*r6ij
14224           fac3=ael6i*r6ij
14225           fac4=ael3i*r3ij
14226           evdwij=ev1+ev2
14227           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14228           el2=fac4*fac
14229           eesij=el1+el2
14230 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14231           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14232           ees=ees+eesij*sss_ele_cut
14233           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14234 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14235 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14236 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14237 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14238
14239           if (energy_dec) then
14240               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14241               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14242           endif
14243
14244 !
14245 ! Calculate contributions to the Cartesian gradient.
14246 !
14247 #ifdef SPLITELE
14248           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14249           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14250           fac1=fac
14251           erij(1)=xj*rmij
14252           erij(2)=yj*rmij
14253           erij(3)=zj*rmij
14254 !
14255 ! Radial derivatives. First process both termini of the fragment (i,j)
14256 !
14257           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14258           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14259           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14260 !          do k=1,3
14261 !            ghalf=0.5D0*ggg(k)
14262 !            gelc(k,i)=gelc(k,i)+ghalf
14263 !            gelc(k,j)=gelc(k,j)+ghalf
14264 !          enddo
14265 ! 9/28/08 AL Gradient compotents will be summed only at the end
14266           do k=1,3
14267             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14268             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14269           enddo
14270 !
14271 ! Loop over residues i+1 thru j-1.
14272 !
14273 !grad          do k=i+1,j-1
14274 !grad            do l=1,3
14275 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14276 !grad            enddo
14277 !grad          enddo
14278           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14279           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14280           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14281           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14282           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14283           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14284 !          do k=1,3
14285 !            ghalf=0.5D0*ggg(k)
14286 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14287 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14288 !          enddo
14289 ! 9/28/08 AL Gradient compotents will be summed only at the end
14290           do k=1,3
14291             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14292             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14293           enddo
14294 !
14295 ! Loop over residues i+1 thru j-1.
14296 !
14297 !grad          do k=i+1,j-1
14298 !grad            do l=1,3
14299 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14300 !grad            enddo
14301 !grad          enddo
14302 #else
14303           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14304           facel=(el1+eesij)*sss_ele_cut
14305           fac1=fac
14306           fac=-3*rrmij*(facvdw+facvdw+facel)
14307           erij(1)=xj*rmij
14308           erij(2)=yj*rmij
14309           erij(3)=zj*rmij
14310 !
14311 ! Radial derivatives. First process both termini of the fragment (i,j)
14312 !
14313           ggg(1)=fac*xj
14314           ggg(2)=fac*yj
14315           ggg(3)=fac*zj
14316 !          do k=1,3
14317 !            ghalf=0.5D0*ggg(k)
14318 !            gelc(k,i)=gelc(k,i)+ghalf
14319 !            gelc(k,j)=gelc(k,j)+ghalf
14320 !          enddo
14321 ! 9/28/08 AL Gradient compotents will be summed only at the end
14322           do k=1,3
14323             gelc_long(k,j)=gelc(k,j)+ggg(k)
14324             gelc_long(k,i)=gelc(k,i)-ggg(k)
14325           enddo
14326 !
14327 ! Loop over residues i+1 thru j-1.
14328 !
14329 !grad          do k=i+1,j-1
14330 !grad            do l=1,3
14331 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14332 !grad            enddo
14333 !grad          enddo
14334 ! 9/28/08 AL Gradient compotents will be summed only at the end
14335           ggg(1)=facvdw*xj
14336           ggg(2)=facvdw*yj
14337           ggg(3)=facvdw*zj
14338           do k=1,3
14339             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14340             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14341           enddo
14342 #endif
14343 !
14344 ! Angular part
14345 !
14346           ecosa=2.0D0*fac3*fac1+fac4
14347           fac4=-3.0D0*fac4
14348           fac3=-6.0D0*fac3
14349           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14350           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14351           do k=1,3
14352             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14353             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14354           enddo
14355 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14356 !d   &          (dcosg(k),k=1,3)
14357           do k=1,3
14358             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14359           enddo
14360 !          do k=1,3
14361 !            ghalf=0.5D0*ggg(k)
14362 !            gelc(k,i)=gelc(k,i)+ghalf
14363 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14364 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14365 !            gelc(k,j)=gelc(k,j)+ghalf
14366 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14367 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14368 !          enddo
14369 !grad          do k=i+1,j-1
14370 !grad            do l=1,3
14371 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14372 !grad            enddo
14373 !grad          enddo
14374           do k=1,3
14375             gelc(k,i)=gelc(k,i) &
14376                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14377                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14378                      *sss_ele_cut
14379             gelc(k,j)=gelc(k,j) &
14380                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14381                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14382                      *sss_ele_cut
14383             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14384             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14385           enddo
14386           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14387               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14388               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14389 !
14390 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14391 !   energy of a peptide unit is assumed in the form of a second-order
14392 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14393 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14394 !   are computed for EVERY pair of non-contiguous peptide groups.
14395 !
14396           if (j.lt.nres-1) then
14397             j1=j+1
14398             j2=j-1
14399           else
14400             j1=j-1
14401             j2=j-2
14402           endif
14403           kkk=0
14404           do k=1,2
14405             do l=1,2
14406               kkk=kkk+1
14407               muij(kkk)=mu(k,i)*mu(l,j)
14408             enddo
14409           enddo
14410 !d         write (iout,*) 'EELEC: i',i,' j',j
14411 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14412 !d          write(iout,*) 'muij',muij
14413           ury=scalar(uy(1,i),erij)
14414           urz=scalar(uz(1,i),erij)
14415           vry=scalar(uy(1,j),erij)
14416           vrz=scalar(uz(1,j),erij)
14417           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14418           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14419           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14420           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14421           fac=dsqrt(-ael6i)*r3ij
14422           a22=a22*fac
14423           a23=a23*fac
14424           a32=a32*fac
14425           a33=a33*fac
14426 !d          write (iout,'(4i5,4f10.5)')
14427 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14428 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14429 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14430 !d     &      uy(:,j),uz(:,j)
14431 !d          write (iout,'(4f10.5)')
14432 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14433 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14434 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14435 !d           write (iout,'(9f10.5/)')
14436 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14437 ! Derivatives of the elements of A in virtual-bond vectors
14438           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14439           do k=1,3
14440             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14441             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14442             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14443             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14444             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14445             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14446             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14447             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14448             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14449             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14450             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14451             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14452           enddo
14453 ! Compute radial contributions to the gradient
14454           facr=-3.0d0*rrmij
14455           a22der=a22*facr
14456           a23der=a23*facr
14457           a32der=a32*facr
14458           a33der=a33*facr
14459           agg(1,1)=a22der*xj
14460           agg(2,1)=a22der*yj
14461           agg(3,1)=a22der*zj
14462           agg(1,2)=a23der*xj
14463           agg(2,2)=a23der*yj
14464           agg(3,2)=a23der*zj
14465           agg(1,3)=a32der*xj
14466           agg(2,3)=a32der*yj
14467           agg(3,3)=a32der*zj
14468           agg(1,4)=a33der*xj
14469           agg(2,4)=a33der*yj
14470           agg(3,4)=a33der*zj
14471 ! Add the contributions coming from er
14472           fac3=-3.0d0*fac
14473           do k=1,3
14474             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14475             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14476             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14477             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14478           enddo
14479           do k=1,3
14480 ! Derivatives in DC(i)
14481 !grad            ghalf1=0.5d0*agg(k,1)
14482 !grad            ghalf2=0.5d0*agg(k,2)
14483 !grad            ghalf3=0.5d0*agg(k,3)
14484 !grad            ghalf4=0.5d0*agg(k,4)
14485             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14486             -3.0d0*uryg(k,2)*vry)!+ghalf1
14487             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14488             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14489             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14490             -3.0d0*urzg(k,2)*vry)!+ghalf3
14491             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14492             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14493 ! Derivatives in DC(i+1)
14494             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14495             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14496             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14497             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14498             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14499             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14500             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14501             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14502 ! Derivatives in DC(j)
14503             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14504             -3.0d0*vryg(k,2)*ury)!+ghalf1
14505             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14506             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14507             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14508             -3.0d0*vryg(k,2)*urz)!+ghalf3
14509             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14510             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14511 ! Derivatives in DC(j+1) or DC(nres-1)
14512             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14513             -3.0d0*vryg(k,3)*ury)
14514             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14515             -3.0d0*vrzg(k,3)*ury)
14516             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14517             -3.0d0*vryg(k,3)*urz)
14518             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14519             -3.0d0*vrzg(k,3)*urz)
14520 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14521 !grad              do l=1,4
14522 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14523 !grad              enddo
14524 !grad            endif
14525           enddo
14526           acipa(1,1)=a22
14527           acipa(1,2)=a23
14528           acipa(2,1)=a32
14529           acipa(2,2)=a33
14530           a22=-a22
14531           a23=-a23
14532           do l=1,2
14533             do k=1,3
14534               agg(k,l)=-agg(k,l)
14535               aggi(k,l)=-aggi(k,l)
14536               aggi1(k,l)=-aggi1(k,l)
14537               aggj(k,l)=-aggj(k,l)
14538               aggj1(k,l)=-aggj1(k,l)
14539             enddo
14540           enddo
14541           if (j.lt.nres-1) then
14542             a22=-a22
14543             a32=-a32
14544             do l=1,3,2
14545               do k=1,3
14546                 agg(k,l)=-agg(k,l)
14547                 aggi(k,l)=-aggi(k,l)
14548                 aggi1(k,l)=-aggi1(k,l)
14549                 aggj(k,l)=-aggj(k,l)
14550                 aggj1(k,l)=-aggj1(k,l)
14551               enddo
14552             enddo
14553           else
14554             a22=-a22
14555             a23=-a23
14556             a32=-a32
14557             a33=-a33
14558             do l=1,4
14559               do k=1,3
14560                 agg(k,l)=-agg(k,l)
14561                 aggi(k,l)=-aggi(k,l)
14562                 aggi1(k,l)=-aggi1(k,l)
14563                 aggj(k,l)=-aggj(k,l)
14564                 aggj1(k,l)=-aggj1(k,l)
14565               enddo
14566             enddo
14567           endif
14568           ENDIF ! WCORR
14569           IF (wel_loc.gt.0.0d0) THEN
14570 ! Contribution to the local-electrostatic energy coming from the i-j pair
14571           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14572            +a33*muij(4)
14573 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14574
14575           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14576                   'eelloc',i,j,eel_loc_ij
14577 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14578
14579           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14580 ! Partial derivatives in virtual-bond dihedral angles gamma
14581           if (i.gt.1) &
14582           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14583                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14584                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14585                  *sss_ele_cut
14586           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14587                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14588                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14589                  *sss_ele_cut
14590            xtemp(1)=xj
14591            xtemp(2)=yj
14592            xtemp(3)=zj
14593
14594 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14595           do l=1,3
14596             ggg(l)=(agg(l,1)*muij(1)+ &
14597                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14598             *sss_ele_cut &
14599              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14600
14601             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14602             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14603 !grad            ghalf=0.5d0*ggg(l)
14604 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14605 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14606           enddo
14607 !grad          do k=i+1,j2
14608 !grad            do l=1,3
14609 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14610 !grad            enddo
14611 !grad          enddo
14612 ! Remaining derivatives of eello
14613           do l=1,3
14614             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14615                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14616             *sss_ele_cut
14617
14618             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14619                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14620             *sss_ele_cut
14621
14622             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14623                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14624             *sss_ele_cut
14625
14626             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14627                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14628             *sss_ele_cut
14629
14630           enddo
14631           ENDIF
14632 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14633 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14634           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14635              .and. num_conti.le.maxconts) then
14636 !            write (iout,*) i,j," entered corr"
14637 !
14638 ! Calculate the contact function. The ith column of the array JCONT will
14639 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14640 ! greater than I). The arrays FACONT and GACONT will contain the values of
14641 ! the contact function and its derivative.
14642 !           r0ij=1.02D0*rpp(iteli,itelj)
14643 !           r0ij=1.11D0*rpp(iteli,itelj)
14644             r0ij=2.20D0*rpp(iteli,itelj)
14645 !           r0ij=1.55D0*rpp(iteli,itelj)
14646             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14647 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14648             if (fcont.gt.0.0D0) then
14649               num_conti=num_conti+1
14650               if (num_conti.gt.maxconts) then
14651 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14652                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14653                                ' will skip next contacts for this conf.',num_conti
14654               else
14655                 jcont_hb(num_conti,i)=j
14656 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14657 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14658                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14659                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14660 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14661 !  terms.
14662                 d_cont(num_conti,i)=rij
14663 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14664 !     --- Electrostatic-interaction matrix ---
14665                 a_chuj(1,1,num_conti,i)=a22
14666                 a_chuj(1,2,num_conti,i)=a23
14667                 a_chuj(2,1,num_conti,i)=a32
14668                 a_chuj(2,2,num_conti,i)=a33
14669 !     --- Gradient of rij
14670                 do kkk=1,3
14671                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14672                 enddo
14673                 kkll=0
14674                 do k=1,2
14675                   do l=1,2
14676                     kkll=kkll+1
14677                     do m=1,3
14678                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14679                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14680                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14681                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14682                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14683                     enddo
14684                   enddo
14685                 enddo
14686                 ENDIF
14687                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14688 ! Calculate contact energies
14689                 cosa4=4.0D0*cosa
14690                 wij=cosa-3.0D0*cosb*cosg
14691                 cosbg1=cosb+cosg
14692                 cosbg2=cosb-cosg
14693 !               fac3=dsqrt(-ael6i)/r0ij**3
14694                 fac3=dsqrt(-ael6i)*r3ij
14695 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14696                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14697                 if (ees0tmp.gt.0) then
14698                   ees0pij=dsqrt(ees0tmp)
14699                 else
14700                   ees0pij=0
14701                 endif
14702 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14703                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14704                 if (ees0tmp.gt.0) then
14705                   ees0mij=dsqrt(ees0tmp)
14706                 else
14707                   ees0mij=0
14708                 endif
14709 !               ees0mij=0.0D0
14710                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14711                      *sss_ele_cut
14712
14713                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14714                      *sss_ele_cut
14715
14716 ! Diagnostics. Comment out or remove after debugging!
14717 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14718 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14719 !               ees0m(num_conti,i)=0.0D0
14720 ! End diagnostics.
14721 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14722 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14723 ! Angular derivatives of the contact function
14724                 ees0pij1=fac3/ees0pij
14725                 ees0mij1=fac3/ees0mij
14726                 fac3p=-3.0D0*fac3*rrmij
14727                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14728                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14729 !               ees0mij1=0.0D0
14730                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14731                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14732                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14733                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14734                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14735                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14736                 ecosap=ecosa1+ecosa2
14737                 ecosbp=ecosb1+ecosb2
14738                 ecosgp=ecosg1+ecosg2
14739                 ecosam=ecosa1-ecosa2
14740                 ecosbm=ecosb1-ecosb2
14741                 ecosgm=ecosg1-ecosg2
14742 ! Diagnostics
14743 !               ecosap=ecosa1
14744 !               ecosbp=ecosb1
14745 !               ecosgp=ecosg1
14746 !               ecosam=0.0D0
14747 !               ecosbm=0.0D0
14748 !               ecosgm=0.0D0
14749 ! End diagnostics
14750                 facont_hb(num_conti,i)=fcont
14751                 fprimcont=fprimcont/rij
14752 !d              facont_hb(num_conti,i)=1.0D0
14753 ! Following line is for diagnostics.
14754 !d              fprimcont=0.0D0
14755                 do k=1,3
14756                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14757                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14758                 enddo
14759                 do k=1,3
14760                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14761                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14762                 enddo
14763 !                gggp(1)=gggp(1)+ees0pijp*xj
14764 !                gggp(2)=gggp(2)+ees0pijp*yj
14765 !                gggp(3)=gggp(3)+ees0pijp*zj
14766 !                gggm(1)=gggm(1)+ees0mijp*xj
14767 !                gggm(2)=gggm(2)+ees0mijp*yj
14768 !                gggm(3)=gggm(3)+ees0mijp*zj
14769                 gggp(1)=gggp(1)+ees0pijp*xj &
14770                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14771                 gggp(2)=gggp(2)+ees0pijp*yj &
14772                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14773                 gggp(3)=gggp(3)+ees0pijp*zj &
14774                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14775
14776                 gggm(1)=gggm(1)+ees0mijp*xj &
14777                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14778
14779                 gggm(2)=gggm(2)+ees0mijp*yj &
14780                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14781
14782                 gggm(3)=gggm(3)+ees0mijp*zj &
14783                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14784
14785 ! Derivatives due to the contact function
14786                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14787                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14788                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14789                 do k=1,3
14790 !
14791 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14792 !          following the change of gradient-summation algorithm.
14793 !
14794 !grad                  ghalfp=0.5D0*gggp(k)
14795 !grad                  ghalfm=0.5D0*gggm(k)
14796 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14797 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14798 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14799 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14800 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14801 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14802 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14803 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14804 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14805 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14806 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14807 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14808 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14809 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14810                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14811                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14812                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14813                      *sss_ele_cut
14814
14815                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14816                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14817                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14818                      *sss_ele_cut
14819
14820                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14821                      *sss_ele_cut
14822
14823                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14824                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14825                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14826                      *sss_ele_cut
14827
14828                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14829                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14830                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14831                      *sss_ele_cut
14832
14833                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14834                      *sss_ele_cut
14835
14836                 enddo
14837               ENDIF ! wcorr
14838               endif  ! num_conti.le.maxconts
14839             endif  ! fcont.gt.0
14840           endif    ! j.gt.i+1
14841           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14842             do k=1,4
14843               do l=1,3
14844                 ghalf=0.5d0*agg(l,k)
14845                 aggi(l,k)=aggi(l,k)+ghalf
14846                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14847                 aggj(l,k)=aggj(l,k)+ghalf
14848               enddo
14849             enddo
14850             if (j.eq.nres-1 .and. i.lt.j-2) then
14851               do k=1,4
14852                 do l=1,3
14853                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14854                 enddo
14855               enddo
14856             endif
14857           endif
14858  128      continue
14859 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14860       return
14861       end subroutine eelecij_scale
14862 !-----------------------------------------------------------------------------
14863       subroutine evdwpp_short(evdw1)
14864 !
14865 ! Compute Evdwpp
14866 !
14867 !      implicit real*8 (a-h,o-z)
14868 !      include 'DIMENSIONS'
14869 !      include 'COMMON.CONTROL'
14870 !      include 'COMMON.IOUNITS'
14871 !      include 'COMMON.GEO'
14872 !      include 'COMMON.VAR'
14873 !      include 'COMMON.LOCAL'
14874 !      include 'COMMON.CHAIN'
14875 !      include 'COMMON.DERIV'
14876 !      include 'COMMON.INTERACT'
14877 !      include 'COMMON.CONTACTS'
14878 !      include 'COMMON.TORSION'
14879 !      include 'COMMON.VECTORS'
14880 !      include 'COMMON.FFIELD'
14881       real(kind=8),dimension(3) :: ggg
14882 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14883 #ifdef MOMENT
14884       real(kind=8) :: scal_el=1.0d0
14885 #else
14886       real(kind=8) :: scal_el=0.5d0
14887 #endif
14888 !el local variables
14889       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14890       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14891       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14892                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14893                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14894       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14895                     dist_temp, dist_init,sss_grad
14896       integer xshift,yshift,zshift
14897
14898
14899       evdw1=0.0D0
14900 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14901 !     & " iatel_e_vdw",iatel_e_vdw
14902       call flush(iout)
14903       do i=iatel_s_vdw,iatel_e_vdw
14904         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
14905         dxi=dc(1,i)
14906         dyi=dc(2,i)
14907         dzi=dc(3,i)
14908         dx_normi=dc_norm(1,i)
14909         dy_normi=dc_norm(2,i)
14910         dz_normi=dc_norm(3,i)
14911         xmedi=c(1,i)+0.5d0*dxi
14912         ymedi=c(2,i)+0.5d0*dyi
14913         zmedi=c(3,i)+0.5d0*dzi
14914           xmedi=dmod(xmedi,boxxsize)
14915           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14916           ymedi=dmod(ymedi,boxysize)
14917           if (ymedi.lt.0) ymedi=ymedi+boxysize
14918           zmedi=dmod(zmedi,boxzsize)
14919           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14920         num_conti=0
14921 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14922 !     &   ' ielend',ielend_vdw(i)
14923         call flush(iout)
14924         do j=ielstart_vdw(i),ielend_vdw(i)
14925           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14926 !el          ind=ind+1
14927           iteli=itel(i)
14928           itelj=itel(j)
14929           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14930           aaa=app(iteli,itelj)
14931           bbb=bpp(iteli,itelj)
14932           dxj=dc(1,j)
14933           dyj=dc(2,j)
14934           dzj=dc(3,j)
14935           dx_normj=dc_norm(1,j)
14936           dy_normj=dc_norm(2,j)
14937           dz_normj=dc_norm(3,j)
14938 !          xj=c(1,j)+0.5D0*dxj-xmedi
14939 !          yj=c(2,j)+0.5D0*dyj-ymedi
14940 !          zj=c(3,j)+0.5D0*dzj-zmedi
14941           xj=c(1,j)+0.5D0*dxj
14942           yj=c(2,j)+0.5D0*dyj
14943           zj=c(3,j)+0.5D0*dzj
14944           xj=mod(xj,boxxsize)
14945           if (xj.lt.0) xj=xj+boxxsize
14946           yj=mod(yj,boxysize)
14947           if (yj.lt.0) yj=yj+boxysize
14948           zj=mod(zj,boxzsize)
14949           if (zj.lt.0) zj=zj+boxzsize
14950       isubchap=0
14951       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14952       xj_safe=xj
14953       yj_safe=yj
14954       zj_safe=zj
14955       do xshift=-1,1
14956       do yshift=-1,1
14957       do zshift=-1,1
14958           xj=xj_safe+xshift*boxxsize
14959           yj=yj_safe+yshift*boxysize
14960           zj=zj_safe+zshift*boxzsize
14961           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14962           if(dist_temp.lt.dist_init) then
14963             dist_init=dist_temp
14964             xj_temp=xj
14965             yj_temp=yj
14966             zj_temp=zj
14967             isubchap=1
14968           endif
14969        enddo
14970        enddo
14971        enddo
14972        if (isubchap.eq.1) then
14973 !C          print *,i,j
14974           xj=xj_temp-xmedi
14975           yj=yj_temp-ymedi
14976           zj=zj_temp-zmedi
14977        else
14978           xj=xj_safe-xmedi
14979           yj=yj_safe-ymedi
14980           zj=zj_safe-zmedi
14981        endif
14982
14983           rij=xj*xj+yj*yj+zj*zj
14984           rrmij=1.0D0/rij
14985           rij=dsqrt(rij)
14986           sss=sscale(rij/rpp(iteli,itelj))
14987             sss_ele_cut=sscale_ele(rij)
14988             sss_ele_grad=sscagrad_ele(rij)
14989             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14990             if (sss_ele_cut.le.0.0) cycle
14991           if (sss.gt.0.0d0) then
14992             rmij=1.0D0/rij
14993             r3ij=rrmij*rmij
14994             r6ij=r3ij*r3ij
14995             ev1=aaa*r6ij*r6ij
14996 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14997             if (j.eq.i+2) ev1=scal_el*ev1
14998             ev2=bbb*r6ij
14999             evdwij=ev1+ev2
15000             if (energy_dec) then
15001               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15002             endif
15003             evdw1=evdw1+evdwij*sss*sss_ele_cut
15004 !
15005 ! Calculate contributions to the Cartesian gradient.
15006 !
15007             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15008 !            ggg(1)=facvdw*xj
15009 !            ggg(2)=facvdw*yj
15010 !            ggg(3)=facvdw*zj
15011           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15012           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15013           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15014           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15015           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15016           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15017
15018             do k=1,3
15019               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15020               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15021             enddo
15022           endif
15023         enddo ! j
15024       enddo   ! i
15025       return
15026       end subroutine evdwpp_short
15027 !-----------------------------------------------------------------------------
15028       subroutine escp_long(evdw2,evdw2_14)
15029 !
15030 ! This subroutine calculates the excluded-volume interaction energy between
15031 ! peptide-group centers and side chains and its gradient in virtual-bond and
15032 ! side-chain vectors.
15033 !
15034 !      implicit real*8 (a-h,o-z)
15035 !      include 'DIMENSIONS'
15036 !      include 'COMMON.GEO'
15037 !      include 'COMMON.VAR'
15038 !      include 'COMMON.LOCAL'
15039 !      include 'COMMON.CHAIN'
15040 !      include 'COMMON.DERIV'
15041 !      include 'COMMON.INTERACT'
15042 !      include 'COMMON.FFIELD'
15043 !      include 'COMMON.IOUNITS'
15044 !      include 'COMMON.CONTROL'
15045       real(kind=8),dimension(3) :: ggg
15046 !el local variables
15047       integer :: i,iint,j,k,iteli,itypj,subchap
15048       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15049       real(kind=8) :: evdw2,evdw2_14,evdwij
15050       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15051                     dist_temp, dist_init
15052
15053       evdw2=0.0D0
15054       evdw2_14=0.0d0
15055 !d    print '(a)','Enter ESCP'
15056 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15057       do i=iatscp_s,iatscp_e
15058         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15059         iteli=itel(i)
15060         xi=0.5D0*(c(1,i)+c(1,i+1))
15061         yi=0.5D0*(c(2,i)+c(2,i+1))
15062         zi=0.5D0*(c(3,i)+c(3,i+1))
15063           xi=mod(xi,boxxsize)
15064           if (xi.lt.0) xi=xi+boxxsize
15065           yi=mod(yi,boxysize)
15066           if (yi.lt.0) yi=yi+boxysize
15067           zi=mod(zi,boxzsize)
15068           if (zi.lt.0) zi=zi+boxzsize
15069
15070         do iint=1,nscp_gr(i)
15071
15072         do j=iscpstart(i,iint),iscpend(i,iint)
15073           itypj=itype(j,1)
15074           if (itypj.eq.ntyp1) cycle
15075 ! Uncomment following three lines for SC-p interactions
15076 !         xj=c(1,nres+j)-xi
15077 !         yj=c(2,nres+j)-yi
15078 !         zj=c(3,nres+j)-zi
15079 ! Uncomment following three lines for Ca-p interactions
15080           xj=c(1,j)
15081           yj=c(2,j)
15082           zj=c(3,j)
15083           xj=mod(xj,boxxsize)
15084           if (xj.lt.0) xj=xj+boxxsize
15085           yj=mod(yj,boxysize)
15086           if (yj.lt.0) yj=yj+boxysize
15087           zj=mod(zj,boxzsize)
15088           if (zj.lt.0) zj=zj+boxzsize
15089       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15090       xj_safe=xj
15091       yj_safe=yj
15092       zj_safe=zj
15093       subchap=0
15094       do xshift=-1,1
15095       do yshift=-1,1
15096       do zshift=-1,1
15097           xj=xj_safe+xshift*boxxsize
15098           yj=yj_safe+yshift*boxysize
15099           zj=zj_safe+zshift*boxzsize
15100           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15101           if(dist_temp.lt.dist_init) then
15102             dist_init=dist_temp
15103             xj_temp=xj
15104             yj_temp=yj
15105             zj_temp=zj
15106             subchap=1
15107           endif
15108        enddo
15109        enddo
15110        enddo
15111        if (subchap.eq.1) then
15112           xj=xj_temp-xi
15113           yj=yj_temp-yi
15114           zj=zj_temp-zi
15115        else
15116           xj=xj_safe-xi
15117           yj=yj_safe-yi
15118           zj=zj_safe-zi
15119        endif
15120           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15121
15122           rij=dsqrt(1.0d0/rrij)
15123             sss_ele_cut=sscale_ele(rij)
15124             sss_ele_grad=sscagrad_ele(rij)
15125 !            print *,sss_ele_cut,sss_ele_grad,&
15126 !            (rij),r_cut_ele,rlamb_ele
15127             if (sss_ele_cut.le.0.0) cycle
15128           sss=sscale((rij/rscp(itypj,iteli)))
15129           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15130           if (sss.lt.1.0d0) then
15131
15132             fac=rrij**expon2
15133             e1=fac*fac*aad(itypj,iteli)
15134             e2=fac*bad(itypj,iteli)
15135             if (iabs(j-i) .le. 2) then
15136               e1=scal14*e1
15137               e2=scal14*e2
15138               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15139             endif
15140             evdwij=e1+e2
15141             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15142             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15143                 'evdw2',i,j,sss,evdwij
15144 !
15145 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15146 !
15147             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15148             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15149             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15150             ggg(1)=xj*fac
15151             ggg(2)=yj*fac
15152             ggg(3)=zj*fac
15153 ! Uncomment following three lines for SC-p interactions
15154 !           do k=1,3
15155 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15156 !           enddo
15157 ! Uncomment following line for SC-p interactions
15158 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15159             do k=1,3
15160               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15161               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15162             enddo
15163           endif
15164         enddo
15165
15166         enddo ! iint
15167       enddo ! i
15168       do i=1,nct
15169         do j=1,3
15170           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15171           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15172           gradx_scp(j,i)=expon*gradx_scp(j,i)
15173         enddo
15174       enddo
15175 !******************************************************************************
15176 !
15177 !                              N O T E !!!
15178 !
15179 ! To save time the factor EXPON has been extracted from ALL components
15180 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15181 ! use!
15182 !
15183 !******************************************************************************
15184       return
15185       end subroutine escp_long
15186 !-----------------------------------------------------------------------------
15187       subroutine escp_short(evdw2,evdw2_14)
15188 !
15189 ! This subroutine calculates the excluded-volume interaction energy between
15190 ! peptide-group centers and side chains and its gradient in virtual-bond and
15191 ! side-chain vectors.
15192 !
15193 !      implicit real*8 (a-h,o-z)
15194 !      include 'DIMENSIONS'
15195 !      include 'COMMON.GEO'
15196 !      include 'COMMON.VAR'
15197 !      include 'COMMON.LOCAL'
15198 !      include 'COMMON.CHAIN'
15199 !      include 'COMMON.DERIV'
15200 !      include 'COMMON.INTERACT'
15201 !      include 'COMMON.FFIELD'
15202 !      include 'COMMON.IOUNITS'
15203 !      include 'COMMON.CONTROL'
15204       real(kind=8),dimension(3) :: ggg
15205 !el local variables
15206       integer :: i,iint,j,k,iteli,itypj,subchap
15207       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15208       real(kind=8) :: evdw2,evdw2_14,evdwij
15209       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15210                     dist_temp, dist_init
15211
15212       evdw2=0.0D0
15213       evdw2_14=0.0d0
15214 !d    print '(a)','Enter ESCP'
15215 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15216       do i=iatscp_s,iatscp_e
15217         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15218         iteli=itel(i)
15219         xi=0.5D0*(c(1,i)+c(1,i+1))
15220         yi=0.5D0*(c(2,i)+c(2,i+1))
15221         zi=0.5D0*(c(3,i)+c(3,i+1))
15222           xi=mod(xi,boxxsize)
15223           if (xi.lt.0) xi=xi+boxxsize
15224           yi=mod(yi,boxysize)
15225           if (yi.lt.0) yi=yi+boxysize
15226           zi=mod(zi,boxzsize)
15227           if (zi.lt.0) zi=zi+boxzsize
15228
15229         do iint=1,nscp_gr(i)
15230
15231         do j=iscpstart(i,iint),iscpend(i,iint)
15232           itypj=itype(j,1)
15233           if (itypj.eq.ntyp1) cycle
15234 ! Uncomment following three lines for SC-p interactions
15235 !         xj=c(1,nres+j)-xi
15236 !         yj=c(2,nres+j)-yi
15237 !         zj=c(3,nres+j)-zi
15238 ! Uncomment following three lines for Ca-p interactions
15239 !          xj=c(1,j)-xi
15240 !          yj=c(2,j)-yi
15241 !          zj=c(3,j)-zi
15242           xj=c(1,j)
15243           yj=c(2,j)
15244           zj=c(3,j)
15245           xj=mod(xj,boxxsize)
15246           if (xj.lt.0) xj=xj+boxxsize
15247           yj=mod(yj,boxysize)
15248           if (yj.lt.0) yj=yj+boxysize
15249           zj=mod(zj,boxzsize)
15250           if (zj.lt.0) zj=zj+boxzsize
15251       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15252       xj_safe=xj
15253       yj_safe=yj
15254       zj_safe=zj
15255       subchap=0
15256       do xshift=-1,1
15257       do yshift=-1,1
15258       do zshift=-1,1
15259           xj=xj_safe+xshift*boxxsize
15260           yj=yj_safe+yshift*boxysize
15261           zj=zj_safe+zshift*boxzsize
15262           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15263           if(dist_temp.lt.dist_init) then
15264             dist_init=dist_temp
15265             xj_temp=xj
15266             yj_temp=yj
15267             zj_temp=zj
15268             subchap=1
15269           endif
15270        enddo
15271        enddo
15272        enddo
15273        if (subchap.eq.1) then
15274           xj=xj_temp-xi
15275           yj=yj_temp-yi
15276           zj=zj_temp-zi
15277        else
15278           xj=xj_safe-xi
15279           yj=yj_safe-yi
15280           zj=zj_safe-zi
15281        endif
15282
15283           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15284           rij=dsqrt(1.0d0/rrij)
15285             sss_ele_cut=sscale_ele(rij)
15286             sss_ele_grad=sscagrad_ele(rij)
15287 !            print *,sss_ele_cut,sss_ele_grad,&
15288 !            (rij),r_cut_ele,rlamb_ele
15289             if (sss_ele_cut.le.0.0) cycle
15290           sss=sscale(rij/rscp(itypj,iteli))
15291           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15292           if (sss.gt.0.0d0) then
15293
15294             fac=rrij**expon2
15295             e1=fac*fac*aad(itypj,iteli)
15296             e2=fac*bad(itypj,iteli)
15297             if (iabs(j-i) .le. 2) then
15298               e1=scal14*e1
15299               e2=scal14*e2
15300               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15301             endif
15302             evdwij=e1+e2
15303             evdw2=evdw2+evdwij*sss*sss_ele_cut
15304             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15305                 'evdw2',i,j,sss,evdwij
15306 !
15307 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15308 !
15309             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15310             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15311             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15312
15313             ggg(1)=xj*fac
15314             ggg(2)=yj*fac
15315             ggg(3)=zj*fac
15316 ! Uncomment following three lines for SC-p interactions
15317 !           do k=1,3
15318 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15319 !           enddo
15320 ! Uncomment following line for SC-p interactions
15321 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15322             do k=1,3
15323               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15324               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15325             enddo
15326           endif
15327         enddo
15328
15329         enddo ! iint
15330       enddo ! i
15331       do i=1,nct
15332         do j=1,3
15333           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15334           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15335           gradx_scp(j,i)=expon*gradx_scp(j,i)
15336         enddo
15337       enddo
15338 !******************************************************************************
15339 !
15340 !                              N O T E !!!
15341 !
15342 ! To save time the factor EXPON has been extracted from ALL components
15343 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15344 ! use!
15345 !
15346 !******************************************************************************
15347       return
15348       end subroutine escp_short
15349 !-----------------------------------------------------------------------------
15350 ! energy_p_new-sep_barrier.F
15351 !-----------------------------------------------------------------------------
15352       subroutine sc_grad_scale(scalfac)
15353 !      implicit real*8 (a-h,o-z)
15354       use calc_data
15355 !      include 'DIMENSIONS'
15356 !      include 'COMMON.CHAIN'
15357 !      include 'COMMON.DERIV'
15358 !      include 'COMMON.CALC'
15359 !      include 'COMMON.IOUNITS'
15360       real(kind=8),dimension(3) :: dcosom1,dcosom2
15361       real(kind=8) :: scalfac
15362 !el local variables
15363 !      integer :: i,j,k,l
15364
15365       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15366       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15367       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15368            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15369 ! diagnostics only
15370 !      eom1=0.0d0
15371 !      eom2=0.0d0
15372 !      eom12=evdwij*eps1_om12
15373 ! end diagnostics
15374 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15375 !     &  " sigder",sigder
15376 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15377 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15378       do k=1,3
15379         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15380         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15381       enddo
15382       do k=1,3
15383         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15384          *sss_ele_cut
15385       enddo
15386 !      write (iout,*) "gg",(gg(k),k=1,3)
15387       do k=1,3
15388         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15389                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15390                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15391                  *sss_ele_cut
15392         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15393                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15394                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15395          *sss_ele_cut
15396 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15397 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15398 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15399 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15400       enddo
15401 !
15402 ! Calculate the components of the gradient in DC and X
15403 !
15404       do l=1,3
15405         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15406         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15407       enddo
15408       return
15409       end subroutine sc_grad_scale
15410 !-----------------------------------------------------------------------------
15411 ! energy_split-sep.F
15412 !-----------------------------------------------------------------------------
15413       subroutine etotal_long(energia)
15414 !
15415 ! Compute the long-range slow-varying contributions to the energy
15416 !
15417 !      implicit real*8 (a-h,o-z)
15418 !      include 'DIMENSIONS'
15419       use MD_data, only: totT,usampl,eq_time
15420 #ifndef ISNAN
15421       external proc_proc
15422 #ifdef WINPGI
15423 !MS$ATTRIBUTES C ::  proc_proc
15424 #endif
15425 #endif
15426 #ifdef MPI
15427       include "mpif.h"
15428       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15429 #endif
15430 !      include 'COMMON.SETUP'
15431 !      include 'COMMON.IOUNITS'
15432 !      include 'COMMON.FFIELD'
15433 !      include 'COMMON.DERIV'
15434 !      include 'COMMON.INTERACT'
15435 !      include 'COMMON.SBRIDGE'
15436 !      include 'COMMON.CHAIN'
15437 !      include 'COMMON.VAR'
15438 !      include 'COMMON.LOCAL'
15439 !      include 'COMMON.MD'
15440       real(kind=8),dimension(0:n_ene) :: energia
15441 !el local variables
15442       integer :: i,n_corr,n_corr1,ierror,ierr
15443       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15444                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15445                   ecorr,ecorr5,ecorr6,eturn6,time00
15446 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15447 !elwrite(iout,*)"in etotal long"
15448
15449       if (modecalc.eq.12.or.modecalc.eq.14) then
15450 #ifdef MPI
15451 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15452 #else
15453         call int_from_cart1(.false.)
15454 #endif
15455       endif
15456 !elwrite(iout,*)"in etotal long"
15457
15458 #ifdef MPI
15459 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15460 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15461       call flush(iout)
15462       if (nfgtasks.gt.1) then
15463         time00=MPI_Wtime()
15464 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15465         if (fg_rank.eq.0) then
15466           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15467 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15468 !          call flush(iout)
15469 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15470 ! FG slaves as WEIGHTS array.
15471           weights_(1)=wsc
15472           weights_(2)=wscp
15473           weights_(3)=welec
15474           weights_(4)=wcorr
15475           weights_(5)=wcorr5
15476           weights_(6)=wcorr6
15477           weights_(7)=wel_loc
15478           weights_(8)=wturn3
15479           weights_(9)=wturn4
15480           weights_(10)=wturn6
15481           weights_(11)=wang
15482           weights_(12)=wscloc
15483           weights_(13)=wtor
15484           weights_(14)=wtor_d
15485           weights_(15)=wstrain
15486           weights_(16)=wvdwpp
15487           weights_(17)=wbond
15488           weights_(18)=scal14
15489           weights_(21)=wsccor
15490 ! FG Master broadcasts the WEIGHTS_ array
15491           call MPI_Bcast(weights_(1),n_ene,&
15492               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15493         else
15494 ! FG slaves receive the WEIGHTS array
15495           call MPI_Bcast(weights(1),n_ene,&
15496               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15497           wsc=weights(1)
15498           wscp=weights(2)
15499           welec=weights(3)
15500           wcorr=weights(4)
15501           wcorr5=weights(5)
15502           wcorr6=weights(6)
15503           wel_loc=weights(7)
15504           wturn3=weights(8)
15505           wturn4=weights(9)
15506           wturn6=weights(10)
15507           wang=weights(11)
15508           wscloc=weights(12)
15509           wtor=weights(13)
15510           wtor_d=weights(14)
15511           wstrain=weights(15)
15512           wvdwpp=weights(16)
15513           wbond=weights(17)
15514           scal14=weights(18)
15515           wsccor=weights(21)
15516         endif
15517         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15518           king,FG_COMM,IERR)
15519          time_Bcast=time_Bcast+MPI_Wtime()-time00
15520          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15521 !        call chainbuild_cart
15522 !        call int_from_cart1(.false.)
15523       endif
15524 !      write (iout,*) 'Processor',myrank,
15525 !     &  ' calling etotal_short ipot=',ipot
15526 !      call flush(iout)
15527 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15528 #endif
15529 !d    print *,'nnt=',nnt,' nct=',nct
15530 !
15531 !elwrite(iout,*)"in etotal long"
15532 ! Compute the side-chain and electrostatic interaction energy
15533 !
15534       goto (101,102,103,104,105,106) ipot
15535 ! Lennard-Jones potential.
15536   101 call elj_long(evdw)
15537 !d    print '(a)','Exit ELJ'
15538       goto 107
15539 ! Lennard-Jones-Kihara potential (shifted).
15540   102 call eljk_long(evdw)
15541       goto 107
15542 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15543   103 call ebp_long(evdw)
15544       goto 107
15545 ! Gay-Berne potential (shifted LJ, angular dependence).
15546   104 call egb_long(evdw)
15547       goto 107
15548 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15549   105 call egbv_long(evdw)
15550       goto 107
15551 ! Soft-sphere potential
15552   106 call e_softsphere(evdw)
15553 !
15554 ! Calculate electrostatic (H-bonding) energy of the main chain.
15555 !
15556   107 continue
15557       call vec_and_deriv
15558       if (ipot.lt.6) then
15559 #ifdef SPLITELE
15560          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15561              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15562              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15563              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15564 #else
15565          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15566              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15567              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15568              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15569 #endif
15570            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15571          else
15572             ees=0
15573             evdw1=0
15574             eel_loc=0
15575             eello_turn3=0
15576             eello_turn4=0
15577          endif
15578       else
15579 !        write (iout,*) "Soft-spheer ELEC potential"
15580         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15581          eello_turn4)
15582       endif
15583 !
15584 ! Calculate excluded-volume interaction energy between peptide groups
15585 ! and side chains.
15586 !
15587       if (ipot.lt.6) then
15588        if(wscp.gt.0d0) then
15589         call escp_long(evdw2,evdw2_14)
15590        else
15591         evdw2=0
15592         evdw2_14=0
15593        endif
15594       else
15595         call escp_soft_sphere(evdw2,evdw2_14)
15596       endif
15597 !
15598 ! 12/1/95 Multi-body terms
15599 !
15600       n_corr=0
15601       n_corr1=0
15602       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15603           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15604          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15605 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15606 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15607       else
15608          ecorr=0.0d0
15609          ecorr5=0.0d0
15610          ecorr6=0.0d0
15611          eturn6=0.0d0
15612       endif
15613       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15614          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15615       endif
15616 !
15617 ! If performing constraint dynamics, call the constraint energy
15618 !  after the equilibration time
15619       if(usampl.and.totT.gt.eq_time) then
15620          call EconstrQ
15621          call Econstr_back
15622       else
15623          Uconst=0.0d0
15624          Uconst_back=0.0d0
15625       endif
15626 !
15627 ! Sum the energies
15628 !
15629       do i=1,n_ene
15630         energia(i)=0.0d0
15631       enddo
15632       energia(1)=evdw
15633 #ifdef SCP14
15634       energia(2)=evdw2-evdw2_14
15635       energia(18)=evdw2_14
15636 #else
15637       energia(2)=evdw2
15638       energia(18)=0.0d0
15639 #endif
15640 #ifdef SPLITELE
15641       energia(3)=ees
15642       energia(16)=evdw1
15643 #else
15644       energia(3)=ees+evdw1
15645       energia(16)=0.0d0
15646 #endif
15647       energia(4)=ecorr
15648       energia(5)=ecorr5
15649       energia(6)=ecorr6
15650       energia(7)=eel_loc
15651       energia(8)=eello_turn3
15652       energia(9)=eello_turn4
15653       energia(10)=eturn6
15654       energia(20)=Uconst+Uconst_back
15655       call sum_energy(energia,.true.)
15656 !      write (iout,*) "Exit ETOTAL_LONG"
15657       call flush(iout)
15658       return
15659       end subroutine etotal_long
15660 !-----------------------------------------------------------------------------
15661       subroutine etotal_short(energia)
15662 !
15663 ! Compute the short-range fast-varying contributions to the energy
15664 !
15665 !      implicit real*8 (a-h,o-z)
15666 !      include 'DIMENSIONS'
15667 #ifndef ISNAN
15668       external proc_proc
15669 #ifdef WINPGI
15670 !MS$ATTRIBUTES C ::  proc_proc
15671 #endif
15672 #endif
15673 #ifdef MPI
15674       include "mpif.h"
15675       integer :: ierror,ierr
15676       real(kind=8),dimension(n_ene) :: weights_
15677       real(kind=8) :: time00
15678 #endif
15679 !      include 'COMMON.SETUP'
15680 !      include 'COMMON.IOUNITS'
15681 !      include 'COMMON.FFIELD'
15682 !      include 'COMMON.DERIV'
15683 !      include 'COMMON.INTERACT'
15684 !      include 'COMMON.SBRIDGE'
15685 !      include 'COMMON.CHAIN'
15686 !      include 'COMMON.VAR'
15687 !      include 'COMMON.LOCAL'
15688       real(kind=8),dimension(0:n_ene) :: energia
15689 !el local variables
15690       integer :: i,nres6
15691       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15692       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15693       nres6=6*nres
15694
15695 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15696 !      call flush(iout)
15697       if (modecalc.eq.12.or.modecalc.eq.14) then
15698 #ifdef MPI
15699         if (fg_rank.eq.0) call int_from_cart1(.false.)
15700 #else
15701         call int_from_cart1(.false.)
15702 #endif
15703       endif
15704 #ifdef MPI
15705 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15706 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15707 !      call flush(iout)
15708       if (nfgtasks.gt.1) then
15709         time00=MPI_Wtime()
15710 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15711         if (fg_rank.eq.0) then
15712           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15713 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15714 !          call flush(iout)
15715 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15716 ! FG slaves as WEIGHTS array.
15717           weights_(1)=wsc
15718           weights_(2)=wscp
15719           weights_(3)=welec
15720           weights_(4)=wcorr
15721           weights_(5)=wcorr5
15722           weights_(6)=wcorr6
15723           weights_(7)=wel_loc
15724           weights_(8)=wturn3
15725           weights_(9)=wturn4
15726           weights_(10)=wturn6
15727           weights_(11)=wang
15728           weights_(12)=wscloc
15729           weights_(13)=wtor
15730           weights_(14)=wtor_d
15731           weights_(15)=wstrain
15732           weights_(16)=wvdwpp
15733           weights_(17)=wbond
15734           weights_(18)=scal14
15735           weights_(21)=wsccor
15736 ! FG Master broadcasts the WEIGHTS_ array
15737           call MPI_Bcast(weights_(1),n_ene,&
15738               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15739         else
15740 ! FG slaves receive the WEIGHTS array
15741           call MPI_Bcast(weights(1),n_ene,&
15742               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15743           wsc=weights(1)
15744           wscp=weights(2)
15745           welec=weights(3)
15746           wcorr=weights(4)
15747           wcorr5=weights(5)
15748           wcorr6=weights(6)
15749           wel_loc=weights(7)
15750           wturn3=weights(8)
15751           wturn4=weights(9)
15752           wturn6=weights(10)
15753           wang=weights(11)
15754           wscloc=weights(12)
15755           wtor=weights(13)
15756           wtor_d=weights(14)
15757           wstrain=weights(15)
15758           wvdwpp=weights(16)
15759           wbond=weights(17)
15760           scal14=weights(18)
15761           wsccor=weights(21)
15762         endif
15763 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15764         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15765           king,FG_COMM,IERR)
15766 !        write (iout,*) "Processor",myrank," BROADCAST c"
15767         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15768           king,FG_COMM,IERR)
15769 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15770         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15771           king,FG_COMM,IERR)
15772 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15773         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15774           king,FG_COMM,IERR)
15775 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15776         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15777           king,FG_COMM,IERR)
15778 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15779         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15780           king,FG_COMM,IERR)
15781 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15782         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15783           king,FG_COMM,IERR)
15784 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15785         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15786           king,FG_COMM,IERR)
15787 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15788         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15789           king,FG_COMM,IERR)
15790          time_Bcast=time_Bcast+MPI_Wtime()-time00
15791 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15792       endif
15793 !      write (iout,*) 'Processor',myrank,
15794 !     &  ' calling etotal_short ipot=',ipot
15795 !      call flush(iout)
15796 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15797 #endif
15798 !      call int_from_cart1(.false.)
15799 !
15800 ! Compute the side-chain and electrostatic interaction energy
15801 !
15802       goto (101,102,103,104,105,106) ipot
15803 ! Lennard-Jones potential.
15804   101 call elj_short(evdw)
15805 !d    print '(a)','Exit ELJ'
15806       goto 107
15807 ! Lennard-Jones-Kihara potential (shifted).
15808   102 call eljk_short(evdw)
15809       goto 107
15810 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15811   103 call ebp_short(evdw)
15812       goto 107
15813 ! Gay-Berne potential (shifted LJ, angular dependence).
15814   104 call egb_short(evdw)
15815       goto 107
15816 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15817   105 call egbv_short(evdw)
15818       goto 107
15819 ! Soft-sphere potential - already dealt with in the long-range part
15820   106 evdw=0.0d0
15821 !  106 call e_softsphere_short(evdw)
15822 !
15823 ! Calculate electrostatic (H-bonding) energy of the main chain.
15824 !
15825   107 continue
15826 !
15827 ! Calculate the short-range part of Evdwpp
15828 !
15829       call evdwpp_short(evdw1)
15830 !
15831 ! Calculate the short-range part of ESCp
15832 !
15833       if (ipot.lt.6) then
15834         call escp_short(evdw2,evdw2_14)
15835       endif
15836 !
15837 ! Calculate the bond-stretching energy
15838 !
15839       call ebond(estr)
15840 !
15841 ! Calculate the disulfide-bridge and other energy and the contributions
15842 ! from other distance constraints.
15843       call edis(ehpb)
15844 !
15845 ! Calculate the virtual-bond-angle energy.
15846 !
15847       call ebend(ebe,ethetacnstr)
15848 !
15849 ! Calculate the SC local energy.
15850 !
15851       call vec_and_deriv
15852       call esc(escloc)
15853 !
15854 ! Calculate the virtual-bond torsional energy.
15855 !
15856       call etor(etors,edihcnstr)
15857 !
15858 ! 6/23/01 Calculate double-torsional energy
15859 !
15860       call etor_d(etors_d)
15861 !
15862 ! 21/5/07 Calculate local sicdechain correlation energy
15863 !
15864       if (wsccor.gt.0.0d0) then
15865         call eback_sc_corr(esccor)
15866       else
15867         esccor=0.0d0
15868       endif
15869 !
15870 ! Put energy components into an array
15871 !
15872       do i=1,n_ene
15873         energia(i)=0.0d0
15874       enddo
15875       energia(1)=evdw
15876 #ifdef SCP14
15877       energia(2)=evdw2-evdw2_14
15878       energia(18)=evdw2_14
15879 #else
15880       energia(2)=evdw2
15881       energia(18)=0.0d0
15882 #endif
15883 #ifdef SPLITELE
15884       energia(16)=evdw1
15885 #else
15886       energia(3)=evdw1
15887 #endif
15888       energia(11)=ebe
15889       energia(12)=escloc
15890       energia(13)=etors
15891       energia(14)=etors_d
15892       energia(15)=ehpb
15893       energia(17)=estr
15894       energia(19)=edihcnstr
15895       energia(21)=esccor
15896 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15897       call flush(iout)
15898       call sum_energy(energia,.true.)
15899 !      write (iout,*) "Exit ETOTAL_SHORT"
15900       call flush(iout)
15901       return
15902       end subroutine etotal_short
15903 !-----------------------------------------------------------------------------
15904 ! gnmr1.f
15905 !-----------------------------------------------------------------------------
15906       real(kind=8) function gnmr1(y,ymin,ymax)
15907 !      implicit none
15908       real(kind=8) :: y,ymin,ymax
15909       real(kind=8) :: wykl=4.0d0
15910       if (y.lt.ymin) then
15911         gnmr1=(ymin-y)**wykl/wykl
15912       else if (y.gt.ymax) then
15913         gnmr1=(y-ymax)**wykl/wykl
15914       else
15915         gnmr1=0.0d0
15916       endif
15917       return
15918       end function gnmr1
15919 !-----------------------------------------------------------------------------
15920       real(kind=8) function gnmr1prim(y,ymin,ymax)
15921 !      implicit none
15922       real(kind=8) :: y,ymin,ymax
15923       real(kind=8) :: wykl=4.0d0
15924       if (y.lt.ymin) then
15925         gnmr1prim=-(ymin-y)**(wykl-1)
15926       else if (y.gt.ymax) then
15927         gnmr1prim=(y-ymax)**(wykl-1)
15928       else
15929         gnmr1prim=0.0d0
15930       endif
15931       return
15932       end function gnmr1prim
15933 !----------------------------------------------------------------------------
15934       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
15935       real(kind=8) y,ymin,ymax,sigma
15936       real(kind=8) wykl /4.0d0/
15937       if (y.lt.ymin) then
15938         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
15939       else if (y.gt.ymax) then
15940         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
15941       else
15942         rlornmr1=0.0d0
15943       endif
15944       return
15945       end function rlornmr1
15946 !------------------------------------------------------------------------------
15947       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
15948       real(kind=8) y,ymin,ymax,sigma
15949       real(kind=8) wykl /4.0d0/
15950       if (y.lt.ymin) then
15951         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
15952         ((ymin-y)**wykl+sigma**wykl)**2
15953       else if (y.gt.ymax) then
15954         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
15955         ((y-ymax)**wykl+sigma**wykl)**2
15956       else
15957         rlornmr1prim=0.0d0
15958       endif
15959       return
15960       end function rlornmr1prim
15961
15962       real(kind=8) function harmonic(y,ymax)
15963 !      implicit none
15964       real(kind=8) :: y,ymax
15965       real(kind=8) :: wykl=2.0d0
15966       harmonic=(y-ymax)**wykl
15967       return
15968       end function harmonic
15969 !-----------------------------------------------------------------------------
15970       real(kind=8) function harmonicprim(y,ymax)
15971       real(kind=8) :: y,ymin,ymax
15972       real(kind=8) :: wykl=2.0d0
15973       harmonicprim=(y-ymax)*wykl
15974       return
15975       end function harmonicprim
15976 !-----------------------------------------------------------------------------
15977 ! gradient_p.F
15978 !-----------------------------------------------------------------------------
15979       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
15980
15981       use io_base, only:intout,briefout
15982 !      implicit real*8 (a-h,o-z)
15983 !      include 'DIMENSIONS'
15984 !      include 'COMMON.CHAIN'
15985 !      include 'COMMON.DERIV'
15986 !      include 'COMMON.VAR'
15987 !      include 'COMMON.INTERACT'
15988 !      include 'COMMON.FFIELD'
15989 !      include 'COMMON.MD'
15990 !      include 'COMMON.IOUNITS'
15991       real(kind=8),external :: ufparm
15992       integer :: uiparm(1)
15993       real(kind=8) :: urparm(1)
15994       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
15995       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
15996       integer :: n,nf,ind,ind1,i,k,j
15997 !
15998 ! This subroutine calculates total internal coordinate gradient.
15999 ! Depending on the number of function evaluations, either whole energy
16000 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16001 ! internal coordinates are reevaluated or only the cartesian-in-internal
16002 ! coordinate derivatives are evaluated. The subroutine was designed to work
16003 ! with SUMSL.
16004 !
16005 !
16006       icg=mod(nf,2)+1
16007
16008 !d      print *,'grad',nf,icg
16009       if (nf-nfl+1) 20,30,40
16010    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16011 !    write (iout,*) 'grad 20'
16012       if (nf.eq.0) return
16013       goto 40
16014    30 call var_to_geom(n,x)
16015       call chainbuild
16016 !    write (iout,*) 'grad 30'
16017 !
16018 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16019 !
16020    40 call cartder
16021 !     write (iout,*) 'grad 40'
16022 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16023 !
16024 ! Convert the Cartesian gradient into internal-coordinate gradient.
16025 !
16026       ind=0
16027       ind1=0
16028       do i=1,nres-2
16029       gthetai=0.0D0
16030       gphii=0.0D0
16031       do j=i+1,nres-1
16032           ind=ind+1
16033 !         ind=indmat(i,j)
16034 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16035         do k=1,3
16036             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16037           enddo
16038         do k=1,3
16039           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16040           enddo
16041         enddo
16042       do j=i+1,nres-1
16043           ind1=ind1+1
16044 !         ind1=indmat(i,j)
16045 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16046         do k=1,3
16047           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16048           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16049           enddo
16050         enddo
16051       if (i.gt.1) g(i-1)=gphii
16052       if (n.gt.nphi) g(nphi+i)=gthetai
16053       enddo
16054       if (n.le.nphi+ntheta) goto 10
16055       do i=2,nres-1
16056       if (itype(i,1).ne.10) then
16057           galphai=0.0D0
16058         gomegai=0.0D0
16059         do k=1,3
16060           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16061           enddo
16062         do k=1,3
16063           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16064           enddo
16065           g(ialph(i,1))=galphai
16066         g(ialph(i,1)+nside)=gomegai
16067         endif
16068       enddo
16069 !
16070 ! Add the components corresponding to local energy terms.
16071 !
16072    10 continue
16073       do i=1,nvar
16074 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16075         g(i)=g(i)+gloc(i,icg)
16076       enddo
16077 ! Uncomment following three lines for diagnostics.
16078 !d    call intout
16079 !elwrite(iout,*) "in gradient after calling intout"
16080 !d    call briefout(0,0.0d0)
16081 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16082       return
16083       end subroutine gradient
16084 !-----------------------------------------------------------------------------
16085       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16086
16087       use comm_chu
16088 !      implicit real*8 (a-h,o-z)
16089 !      include 'DIMENSIONS'
16090 !      include 'COMMON.DERIV'
16091 !      include 'COMMON.IOUNITS'
16092 !      include 'COMMON.GEO'
16093       integer :: n,nf
16094 !el      integer :: jjj
16095 !el      common /chuju/ jjj
16096       real(kind=8) :: energia(0:n_ene)
16097       integer :: uiparm(1)
16098       real(kind=8) :: urparm(1)
16099       real(kind=8) :: f
16100       real(kind=8),external :: ufparm
16101       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16102 !     if (jjj.gt.0) then
16103 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16104 !     endif
16105       nfl=nf
16106       icg=mod(nf,2)+1
16107 !d      print *,'func',nf,nfl,icg
16108       call var_to_geom(n,x)
16109       call zerograd
16110       call chainbuild
16111 !d    write (iout,*) 'ETOTAL called from FUNC'
16112       call etotal(energia)
16113       call sum_gradient
16114       f=energia(0)
16115 !     if (jjj.gt.0) then
16116 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16117 !       write (iout,*) 'f=',etot
16118 !       jjj=0
16119 !     endif
16120       return
16121       end subroutine func
16122 !-----------------------------------------------------------------------------
16123       subroutine cartgrad
16124 !      implicit real*8 (a-h,o-z)
16125 !      include 'DIMENSIONS'
16126       use energy_data
16127       use MD_data, only: totT,usampl,eq_time
16128 #ifdef MPI
16129       include 'mpif.h'
16130 #endif
16131 !      include 'COMMON.CHAIN'
16132 !      include 'COMMON.DERIV'
16133 !      include 'COMMON.VAR'
16134 !      include 'COMMON.INTERACT'
16135 !      include 'COMMON.FFIELD'
16136 !      include 'COMMON.MD'
16137 !      include 'COMMON.IOUNITS'
16138 !      include 'COMMON.TIME1'
16139 !
16140       integer :: i,j
16141
16142 ! This subrouting calculates total Cartesian coordinate gradient.
16143 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16144 !
16145 !el#define DEBUG
16146 #ifdef TIMING
16147       time00=MPI_Wtime()
16148 #endif
16149       icg=1
16150       call sum_gradient
16151 #ifdef TIMING
16152 #endif
16153 !el      write (iout,*) "After sum_gradient"
16154 #ifdef DEBUG
16155 !el      write (iout,*) "After sum_gradient"
16156       do i=1,nres-1
16157         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16158         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16159       enddo
16160 #endif
16161 ! If performing constraint dynamics, add the gradients of the constraint energy
16162       if(usampl.and.totT.gt.eq_time) then
16163          do i=1,nct
16164            do j=1,3
16165              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16166              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16167            enddo
16168          enddo
16169          do i=1,nres-3
16170            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16171          enddo
16172          do i=1,nres-2
16173            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16174          enddo
16175       endif
16176 !elwrite (iout,*) "After sum_gradient"
16177 #ifdef TIMING
16178       time01=MPI_Wtime()
16179 #endif
16180       call intcartderiv
16181 !elwrite (iout,*) "After sum_gradient"
16182 #ifdef TIMING
16183       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16184 #endif
16185 !     call checkintcartgrad
16186 !     write(iout,*) 'calling int_to_cart'
16187 #ifdef DEBUG
16188       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16189 #endif
16190       do i=0,nct
16191         do j=1,3
16192           gcart(j,i)=gradc(j,i,icg)
16193           gxcart(j,i)=gradx(j,i,icg)
16194 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16195         enddo
16196 #ifdef DEBUG
16197         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16198           (gxcart(j,i),j=1,3),gloc(i,icg)
16199 #endif
16200       enddo
16201 #ifdef TIMING
16202       time01=MPI_Wtime()
16203 #endif
16204 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16205       call int_to_cart
16206 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16207
16208 #ifdef TIMING
16209             time_inttocart=time_inttocart+MPI_Wtime()-time01
16210 #endif
16211 #ifdef DEBUG
16212             write (iout,*) "gcart and gxcart after int_to_cart"
16213             do i=0,nres-1
16214             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16215                 (gxcart(j,i),j=1,3)
16216             enddo
16217 #endif
16218 #ifdef CARGRAD
16219 #ifdef DEBUG
16220             write (iout,*) "CARGRAD"
16221 #endif
16222             do i=nres,0,-1
16223             do j=1,3
16224               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16225       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16226             enddo
16227       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16228       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16229             enddo
16230       ! Correction: dummy residues
16231             if (nnt.gt.1) then
16232               do j=1,3
16233       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16234                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16235               enddo
16236             endif
16237             if (nct.lt.nres) then
16238               do j=1,3
16239       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16240                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16241               enddo
16242             endif
16243 #endif
16244 #ifdef TIMING
16245             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16246 #endif
16247       !el#undef DEBUG
16248             return
16249             end subroutine cartgrad
16250       !-----------------------------------------------------------------------------
16251             subroutine zerograd
16252       !      implicit real*8 (a-h,o-z)
16253       !      include 'DIMENSIONS'
16254       !      include 'COMMON.DERIV'
16255       !      include 'COMMON.CHAIN'
16256       !      include 'COMMON.VAR'
16257       !      include 'COMMON.MD'
16258       !      include 'COMMON.SCCOR'
16259       !
16260       !el local variables
16261             integer :: i,j,intertyp,k
16262       ! Initialize Cartesian-coordinate gradient
16263       !
16264       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16265       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16266
16267       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16268       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16269       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16270       !      allocate(gradcorr_long(3,nres))
16271       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16272       !      allocate(gcorr6_turn_long(3,nres))
16273       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16274
16275       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16276
16277       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16278       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16279
16280       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16281       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16282
16283       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16284       !      allocate(gscloc(3,nres)) !(3,maxres)
16285       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16286
16287
16288
16289       !      common /deriv_scloc/
16290       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16291       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16292       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16293       !      common /mpgrad/
16294       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16295
16296
16297
16298       !          gradc(j,i,icg)=0.0d0
16299       !          gradx(j,i,icg)=0.0d0
16300
16301       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16302       !elwrite(iout,*) "icg",icg
16303             do i=-1,nres
16304             do j=1,3
16305               gvdwx(j,i)=0.0D0
16306               gradx_scp(j,i)=0.0D0
16307               gvdwc(j,i)=0.0D0
16308               gvdwc_scp(j,i)=0.0D0
16309               gvdwc_scpp(j,i)=0.0d0
16310               gelc(j,i)=0.0D0
16311               gelc_long(j,i)=0.0D0
16312               gradb(j,i)=0.0d0
16313               gradbx(j,i)=0.0d0
16314               gvdwpp(j,i)=0.0d0
16315               gel_loc(j,i)=0.0d0
16316               gel_loc_long(j,i)=0.0d0
16317               ghpbc(j,i)=0.0D0
16318               ghpbx(j,i)=0.0D0
16319               gcorr3_turn(j,i)=0.0d0
16320               gcorr4_turn(j,i)=0.0d0
16321               gradcorr(j,i)=0.0d0
16322               gradcorr_long(j,i)=0.0d0
16323               gradcorr5_long(j,i)=0.0d0
16324               gradcorr6_long(j,i)=0.0d0
16325               gcorr6_turn_long(j,i)=0.0d0
16326               gradcorr5(j,i)=0.0d0
16327               gradcorr6(j,i)=0.0d0
16328               gcorr6_turn(j,i)=0.0d0
16329               gsccorc(j,i)=0.0d0
16330               gsccorx(j,i)=0.0d0
16331               gradc(j,i,icg)=0.0d0
16332               gradx(j,i,icg)=0.0d0
16333               gscloc(j,i)=0.0d0
16334               gsclocx(j,i)=0.0d0
16335               gliptran(j,i)=0.0d0
16336               gliptranx(j,i)=0.0d0
16337               gliptranc(j,i)=0.0d0
16338               gshieldx(j,i)=0.0d0
16339               gshieldc(j,i)=0.0d0
16340               gshieldc_loc(j,i)=0.0d0
16341               gshieldx_ec(j,i)=0.0d0
16342               gshieldc_ec(j,i)=0.0d0
16343               gshieldc_loc_ec(j,i)=0.0d0
16344               gshieldx_t3(j,i)=0.0d0
16345               gshieldc_t3(j,i)=0.0d0
16346               gshieldc_loc_t3(j,i)=0.0d0
16347               gshieldx_t4(j,i)=0.0d0
16348               gshieldc_t4(j,i)=0.0d0
16349               gshieldc_loc_t4(j,i)=0.0d0
16350               gshieldx_ll(j,i)=0.0d0
16351               gshieldc_ll(j,i)=0.0d0
16352               gshieldc_loc_ll(j,i)=0.0d0
16353               gg_tube(j,i)=0.0d0
16354               gg_tube_sc(j,i)=0.0d0
16355               gradafm(j,i)=0.0d0
16356               gradb_nucl(j,i)=0.0d0
16357               gradbx_nucl(j,i)=0.0d0
16358               gvdwpp_nucl(j,i)=0.0d0
16359               gvdwpp(j,i)=0.0d0
16360               gelpp(j,i)=0.0d0
16361               gvdwpsb(j,i)=0.0d0
16362               gvdwpsb1(j,i)=0.0d0
16363               gvdwsbc(j,i)=0.0d0
16364               gvdwsbx(j,i)=0.0d0
16365               gelsbc(j,i)=0.0d0
16366               gradcorr_nucl(j,i)=0.0d0
16367               gradcorr3_nucl(j,i)=0.0d0
16368               gradxorr_nucl(j,i)=0.0d0
16369               gradxorr3_nucl(j,i)=0.0d0
16370               gelsbx(j,i)=0.0d0
16371               gsbloc(j,i)=0.0d0
16372               gsblocx(j,i)=0.0d0
16373               gradpepcat(j,i)=0.0d0
16374               gradpepcatx(j,i)=0.0d0
16375               gradcatcat(j,i)=0.0d0
16376             enddo
16377              enddo
16378             do i=0,nres
16379             do j=1,3
16380               do intertyp=1,3
16381                gloc_sc(intertyp,i,icg)=0.0d0
16382               enddo
16383             enddo
16384             enddo
16385             do i=1,nres
16386              do j=1,maxcontsshi
16387              shield_list(j,i)=0
16388             do k=1,3
16389       !C           print *,i,j,k
16390                grad_shield_side(k,j,i)=0.0d0
16391                grad_shield_loc(k,j,i)=0.0d0
16392              enddo
16393              enddo
16394              ishield_list(i)=0
16395             enddo
16396
16397       !
16398       ! Initialize the gradient of local energy terms.
16399       !
16400       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16401       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16402       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16403       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16404       !      allocate(gel_loc_turn3(nres))
16405       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16406       !      allocate(gsccor_loc(nres))      !(maxres)
16407
16408             do i=1,4*nres
16409             gloc(i,icg)=0.0D0
16410             enddo
16411             do i=1,nres
16412             gel_loc_loc(i)=0.0d0
16413             gcorr_loc(i)=0.0d0
16414             g_corr5_loc(i)=0.0d0
16415             g_corr6_loc(i)=0.0d0
16416             gel_loc_turn3(i)=0.0d0
16417             gel_loc_turn4(i)=0.0d0
16418             gel_loc_turn6(i)=0.0d0
16419             gsccor_loc(i)=0.0d0
16420             enddo
16421       ! initialize gcart and gxcart
16422       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16423             do i=0,nres
16424             do j=1,3
16425               gcart(j,i)=0.0d0
16426               gxcart(j,i)=0.0d0
16427             enddo
16428             enddo
16429             return
16430             end subroutine zerograd
16431       !-----------------------------------------------------------------------------
16432             real(kind=8) function fdum()
16433             fdum=0.0D0
16434             return
16435             end function fdum
16436       !-----------------------------------------------------------------------------
16437       ! intcartderiv.F
16438       !-----------------------------------------------------------------------------
16439             subroutine intcartderiv
16440       !      implicit real*8 (a-h,o-z)
16441       !      include 'DIMENSIONS'
16442 #ifdef MPI
16443             include 'mpif.h'
16444 #endif
16445       !      include 'COMMON.SETUP'
16446       !      include 'COMMON.CHAIN'
16447       !      include 'COMMON.VAR'
16448       !      include 'COMMON.GEO'
16449       !      include 'COMMON.INTERACT'
16450       !      include 'COMMON.DERIV'
16451       !      include 'COMMON.IOUNITS'
16452       !      include 'COMMON.LOCAL'
16453       !      include 'COMMON.SCCOR'
16454             real(kind=8) :: pi4,pi34
16455             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16456             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16457                       dcosomega,dsinomega !(3,3,maxres)
16458             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16459
16460             integer :: i,j,k
16461             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16462                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16463                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16464                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16465             integer :: nres2
16466             nres2=2*nres
16467
16468       !el from module energy-------------
16469       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16470       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16471       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16472
16473       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16474       !el      allocate(dsintau(3,3,3,0:nres2))
16475       !el      allocate(dtauangle(3,3,3,0:nres2))
16476       !el      allocate(domicron(3,2,2,0:nres2))
16477       !el      allocate(dcosomicron(3,2,2,0:nres2))
16478
16479
16480
16481 #if defined(MPI) && defined(PARINTDER)
16482             if (nfgtasks.gt.1 .and. me.eq.king) &
16483             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16484 #endif
16485             pi4 = 0.5d0*pipol
16486             pi34 = 3*pi4
16487
16488       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
16489       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16490
16491       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16492             do i=1,nres
16493             do j=1,3
16494               dtheta(j,1,i)=0.0d0
16495               dtheta(j,2,i)=0.0d0
16496               dphi(j,1,i)=0.0d0
16497               dphi(j,2,i)=0.0d0
16498               dphi(j,3,i)=0.0d0
16499             enddo
16500             enddo
16501       ! Derivatives of theta's
16502 #if defined(MPI) && defined(PARINTDER)
16503       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16504             do i=max0(ithet_start-1,3),ithet_end
16505 #else
16506             do i=3,nres
16507 #endif
16508             cost=dcos(theta(i))
16509             sint=sqrt(1-cost*cost)
16510             do j=1,3
16511               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16512               vbld(i-1)
16513               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16514               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16515               vbld(i)
16516               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16517             enddo
16518             enddo
16519 #if defined(MPI) && defined(PARINTDER)
16520       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16521             do i=max0(ithet_start-1,3),ithet_end
16522 #else
16523             do i=3,nres
16524 #endif
16525             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16526             cost1=dcos(omicron(1,i))
16527             sint1=sqrt(1-cost1*cost1)
16528             cost2=dcos(omicron(2,i))
16529             sint2=sqrt(1-cost2*cost2)
16530              do j=1,3
16531       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16532               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16533               cost1*dc_norm(j,i-2))/ &
16534               vbld(i-1)
16535               domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16536               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16537               +cost1*(dc_norm(j,i-1+nres)))/ &
16538               vbld(i-1+nres)
16539               domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16540       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16541       !C Looks messy but better than if in loop
16542               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16543               +cost2*dc_norm(j,i-1))/ &
16544               vbld(i)
16545               domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16546               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16547                +cost2*(-dc_norm(j,i-1+nres)))/ &
16548               vbld(i-1+nres)
16549       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16550               domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16551             enddo
16552              endif
16553             enddo
16554       !elwrite(iout,*) "after vbld write"
16555       ! Derivatives of phi:
16556       ! If phi is 0 or 180 degrees, then the formulas
16557       ! have to be derived by power series expansion of the
16558       ! conventional formulas around 0 and 180.
16559 #ifdef PARINTDER
16560             do i=iphi1_start,iphi1_end
16561 #else
16562             do i=4,nres
16563 #endif
16564       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16565       ! the conventional case
16566             sint=dsin(theta(i))
16567             sint1=dsin(theta(i-1))
16568             sing=dsin(phi(i))
16569             cost=dcos(theta(i))
16570             cost1=dcos(theta(i-1))
16571             cosg=dcos(phi(i))
16572             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16573             fac0=1.0d0/(sint1*sint)
16574             fac1=cost*fac0
16575             fac2=cost1*fac0
16576             fac3=cosg*cost1/(sint1*sint1)
16577             fac4=cosg*cost/(sint*sint)
16578       !    Obtaining the gamma derivatives from sine derivative
16579              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16580                phi(i).gt.pi34.and.phi(i).le.pi.or. &
16581                phi(i).ge.-pi.and.phi(i).le.-pi34) then
16582              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16583              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16584              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16585              do j=1,3
16586                 ctgt=cost/sint
16587                 ctgt1=cost1/sint1
16588                 cosg_inv=1.0d0/cosg
16589                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16590                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16591                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16592                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16593                 dsinphi(j,2,i)= &
16594                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16595                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16596                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16597                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16598                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16599       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16600                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16601                 endif
16602       ! Bug fixed 3/24/05 (AL)
16603              enddo
16604       !   Obtaining the gamma derivatives from cosine derivative
16605             else
16606                do j=1,3
16607                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16608                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16609                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16610                dc_norm(j,i-3))/vbld(i-2)
16611                dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16612                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16613                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16614                dcostheta(j,1,i)
16615                dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16616                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16617                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16618                dc_norm(j,i-1))/vbld(i)
16619                dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16620                endif
16621              enddo
16622             endif
16623             enddo
16624       !alculate derivative of Tauangle
16625 #ifdef PARINTDER
16626             do i=itau_start,itau_end
16627 #else
16628             do i=3,nres
16629       !elwrite(iout,*) " vecpr",i,nres
16630 #endif
16631              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16632       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16633       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16634       !c dtauangle(j,intertyp,dervityp,residue number)
16635       !c INTERTYP=1 SC...Ca...Ca..Ca
16636       ! the conventional case
16637             sint=dsin(theta(i))
16638             sint1=dsin(omicron(2,i-1))
16639             sing=dsin(tauangle(1,i))
16640             cost=dcos(theta(i))
16641             cost1=dcos(omicron(2,i-1))
16642             cosg=dcos(tauangle(1,i))
16643       !elwrite(iout,*) " vecpr5",i,nres
16644             do j=1,3
16645       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16646       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16647             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16648       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16649             enddo
16650             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16651             fac0=1.0d0/(sint1*sint)
16652             fac1=cost*fac0
16653             fac2=cost1*fac0
16654             fac3=cosg*cost1/(sint1*sint1)
16655             fac4=cosg*cost/(sint*sint)
16656       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16657       !    Obtaining the gamma derivatives from sine derivative
16658              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16659                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16660                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16661              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16662              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16663              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16664             do j=1,3
16665                 ctgt=cost/sint
16666                 ctgt1=cost1/sint1
16667                 cosg_inv=1.0d0/cosg
16668                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16669              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16670              *vbld_inv(i-2+nres)
16671                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16672                 dsintau(j,1,2,i)= &
16673                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16674                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16675       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16676                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16677       ! Bug fixed 3/24/05 (AL)
16678                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16679                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16680       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16681                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16682              enddo
16683       !   Obtaining the gamma derivatives from cosine derivative
16684             else
16685                do j=1,3
16686                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16687                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16688                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16689                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16690                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16691                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16692                dcostheta(j,1,i)
16693                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16694                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16695                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16696                dc_norm(j,i-1))/vbld(i)
16697                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16698       !         write (iout,*) "else",i
16699              enddo
16700             endif
16701       !        do k=1,3
16702       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16703       !        enddo
16704             enddo
16705       !C Second case Ca...Ca...Ca...SC
16706 #ifdef PARINTDER
16707             do i=itau_start,itau_end
16708 #else
16709             do i=4,nres
16710 #endif
16711              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16712               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16713       ! the conventional case
16714             sint=dsin(omicron(1,i))
16715             sint1=dsin(theta(i-1))
16716             sing=dsin(tauangle(2,i))
16717             cost=dcos(omicron(1,i))
16718             cost1=dcos(theta(i-1))
16719             cosg=dcos(tauangle(2,i))
16720       !        do j=1,3
16721       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16722       !        enddo
16723             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16724             fac0=1.0d0/(sint1*sint)
16725             fac1=cost*fac0
16726             fac2=cost1*fac0
16727             fac3=cosg*cost1/(sint1*sint1)
16728             fac4=cosg*cost/(sint*sint)
16729       !    Obtaining the gamma derivatives from sine derivative
16730              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16731                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16732                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16733              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16734              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16735              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16736             do j=1,3
16737                 ctgt=cost/sint
16738                 ctgt1=cost1/sint1
16739                 cosg_inv=1.0d0/cosg
16740                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16741                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16742       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16743       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16744                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16745                 dsintau(j,2,2,i)= &
16746                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16747                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16748       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16749       !     & sing*ctgt*domicron(j,1,2,i),
16750       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16751                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16752       ! Bug fixed 3/24/05 (AL)
16753                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16754                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16755       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16756                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16757              enddo
16758       !   Obtaining the gamma derivatives from cosine derivative
16759             else
16760                do j=1,3
16761                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16762                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16763                dc_norm(j,i-3))/vbld(i-2)
16764                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16765                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16766                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16767                dcosomicron(j,1,1,i)
16768                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16769                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16770                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16771                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16772                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16773       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16774              enddo
16775             endif
16776             enddo
16777
16778       !CC third case SC...Ca...Ca...SC
16779 #ifdef PARINTDER
16780
16781             do i=itau_start,itau_end
16782 #else
16783             do i=3,nres
16784 #endif
16785       ! the conventional case
16786             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16787             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16788             sint=dsin(omicron(1,i))
16789             sint1=dsin(omicron(2,i-1))
16790             sing=dsin(tauangle(3,i))
16791             cost=dcos(omicron(1,i))
16792             cost1=dcos(omicron(2,i-1))
16793             cosg=dcos(tauangle(3,i))
16794             do j=1,3
16795             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16796       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16797             enddo
16798             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16799             fac0=1.0d0/(sint1*sint)
16800             fac1=cost*fac0
16801             fac2=cost1*fac0
16802             fac3=cosg*cost1/(sint1*sint1)
16803             fac4=cosg*cost/(sint*sint)
16804       !    Obtaining the gamma derivatives from sine derivative
16805              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16806                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16807                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16808              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16809              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16810              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16811             do j=1,3
16812                 ctgt=cost/sint
16813                 ctgt1=cost1/sint1
16814                 cosg_inv=1.0d0/cosg
16815                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16816                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16817                   *vbld_inv(i-2+nres)
16818                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16819                 dsintau(j,3,2,i)= &
16820                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16821                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16822                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16823       ! Bug fixed 3/24/05 (AL)
16824                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16825                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16826                   *vbld_inv(i-1+nres)
16827       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16828                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16829              enddo
16830       !   Obtaining the gamma derivatives from cosine derivative
16831             else
16832                do j=1,3
16833                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16834                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16835                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16836                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16837                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16838                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16839                dcosomicron(j,1,1,i)
16840                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16841                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16842                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16843                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16844                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16845       !          write(iout,*) "else",i
16846              enddo
16847             endif
16848             enddo
16849
16850 #ifdef CRYST_SC
16851       !   Derivatives of side-chain angles alpha and omega
16852 #if defined(MPI) && defined(PARINTDER)
16853             do i=ibond_start,ibond_end
16854 #else
16855             do i=2,nres-1
16856 #endif
16857               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16858                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16859                  fac6=fac5/vbld(i)
16860                  fac7=fac5*fac5
16861                  fac8=fac5/vbld(i+1)
16862                  fac9=fac5/vbld(i+nres)
16863                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16864                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16865                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16866                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16867                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16868                  sina=sqrt(1-cosa*cosa)
16869                  sino=dsin(omeg(i))
16870       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16871                  do j=1,3
16872                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16873                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16874                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16875                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16876                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16877                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16878                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16879                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16880                   vbld(i+nres))
16881                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16882                 enddo
16883       ! obtaining the derivatives of omega from sines
16884                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16885                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16886                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16887                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16888                    dsin(theta(i+1)))
16889                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16890                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16891                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16892                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16893                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16894                    coso_inv=1.0d0/dcos(omeg(i))
16895                    do j=1,3
16896                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16897                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16898                    (sino*dc_norm(j,i-1))/vbld(i)
16899                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16900                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16901                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16902                    -sino*dc_norm(j,i)/vbld(i+1)
16903                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16904                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16905                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16906                    vbld(i+nres)
16907                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16908                   enddo
16909                else
16910       !   obtaining the derivatives of omega from cosines
16911                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16912                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16913                  fac12=fac10*sina
16914                  fac13=fac12*fac12
16915                  fac14=sina*sina
16916                  do j=1,3
16917                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16918                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16919                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16920                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16921                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
16922                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
16923                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
16924                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
16925                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
16926                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
16927                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
16928                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
16929                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
16930                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
16931                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
16932                 enddo
16933               endif
16934              else
16935                do j=1,3
16936                  do k=1,3
16937                    dalpha(k,j,i)=0.0d0
16938                    domega(k,j,i)=0.0d0
16939                  enddo
16940                enddo
16941              endif
16942              enddo
16943 #endif
16944 #if defined(MPI) && defined(PARINTDER)
16945             if (nfgtasks.gt.1) then
16946 #ifdef DEBUG
16947       !d      write (iout,*) "Gather dtheta"
16948       !d      call flush(iout)
16949             write (iout,*) "dtheta before gather"
16950             do i=1,nres
16951             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
16952             enddo
16953 #endif
16954             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
16955             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
16956             king,FG_COMM,IERROR)
16957 #ifdef DEBUG
16958       !d      write (iout,*) "Gather dphi"
16959       !d      call flush(iout)
16960             write (iout,*) "dphi before gather"
16961             do i=1,nres
16962             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
16963             enddo
16964 #endif
16965             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
16966             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
16967             king,FG_COMM,IERROR)
16968       !d      write (iout,*) "Gather dalpha"
16969       !d      call flush(iout)
16970 #ifdef CRYST_SC
16971             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
16972             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16973             king,FG_COMM,IERROR)
16974       !d      write (iout,*) "Gather domega"
16975       !d      call flush(iout)
16976             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
16977             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16978             king,FG_COMM,IERROR)
16979 #endif
16980             endif
16981 #endif
16982 #ifdef DEBUG
16983             write (iout,*) "dtheta after gather"
16984             do i=1,nres
16985             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
16986             enddo
16987             write (iout,*) "dphi after gather"
16988             do i=1,nres
16989             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
16990             enddo
16991             write (iout,*) "dalpha after gather"
16992             do i=1,nres
16993             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
16994             enddo
16995             write (iout,*) "domega after gather"
16996             do i=1,nres
16997             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
16998             enddo
16999 #endif
17000             return
17001             end subroutine intcartderiv
17002       !-----------------------------------------------------------------------------
17003             subroutine checkintcartgrad
17004       !      implicit real*8 (a-h,o-z)
17005       !      include 'DIMENSIONS'
17006 #ifdef MPI
17007             include 'mpif.h'
17008 #endif
17009       !      include 'COMMON.CHAIN'
17010       !      include 'COMMON.VAR'
17011       !      include 'COMMON.GEO'
17012       !      include 'COMMON.INTERACT'
17013       !      include 'COMMON.DERIV'
17014       !      include 'COMMON.IOUNITS'
17015       !      include 'COMMON.SETUP'
17016             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17017             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17018             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17019             real(kind=8),dimension(3) :: dc_norm_s
17020             real(kind=8) :: aincr=1.0d-5
17021             integer :: i,j
17022             real(kind=8) :: dcji
17023             do i=1,nres
17024             phi_s(i)=phi(i)
17025             theta_s(i)=theta(i)
17026             alph_s(i)=alph(i)
17027             omeg_s(i)=omeg(i)
17028             enddo
17029       ! Check theta gradient
17030             write (iout,*) &
17031              "Analytical (upper) and numerical (lower) gradient of theta"
17032             write (iout,*)
17033             do i=3,nres
17034             do j=1,3
17035               dcji=dc(j,i-2)
17036               dc(j,i-2)=dcji+aincr
17037               call chainbuild_cart
17038               call int_from_cart1(.false.)
17039           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17040           dc(j,i-2)=dcji
17041           dcji=dc(j,i-1)
17042           dc(j,i-1)=dc(j,i-1)+aincr
17043           call chainbuild_cart
17044           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17045           dc(j,i-1)=dcji
17046         enddo
17047 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17048 !el          (dtheta(j,2,i),j=1,3)
17049 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17050 !el          (dthetanum(j,2,i),j=1,3)
17051 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17052 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17053 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17054 !el        write (iout,*)
17055       enddo
17056 ! Check gamma gradient
17057       write (iout,*) &
17058        "Analytical (upper) and numerical (lower) gradient of gamma"
17059       do i=4,nres
17060         do j=1,3
17061           dcji=dc(j,i-3)
17062           dc(j,i-3)=dcji+aincr
17063           call chainbuild_cart
17064           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17065               dc(j,i-3)=dcji
17066           dcji=dc(j,i-2)
17067           dc(j,i-2)=dcji+aincr
17068           call chainbuild_cart
17069           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17070           dc(j,i-2)=dcji
17071           dcji=dc(j,i-1)
17072           dc(j,i-1)=dc(j,i-1)+aincr
17073           call chainbuild_cart
17074           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17075           dc(j,i-1)=dcji
17076         enddo
17077 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17078 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17079 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17080 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17081 !el        write (iout,'(5x,3(3f10.5,5x))') &
17082 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17083 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17084 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17085 !el        write (iout,*)
17086       enddo
17087 ! Check alpha gradient
17088       write (iout,*) &
17089        "Analytical (upper) and numerical (lower) gradient of alpha"
17090       do i=2,nres-1
17091        if(itype(i,1).ne.10) then
17092                  do j=1,3
17093                   dcji=dc(j,i-1)
17094                    dc(j,i-1)=dcji+aincr
17095               call chainbuild_cart
17096               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17097                  /aincr
17098                   dc(j,i-1)=dcji
17099               dcji=dc(j,i)
17100               dc(j,i)=dcji+aincr
17101               call chainbuild_cart
17102               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17103                  /aincr
17104               dc(j,i)=dcji
17105               dcji=dc(j,i+nres)
17106               dc(j,i+nres)=dc(j,i+nres)+aincr
17107               call chainbuild_cart
17108               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17109                  /aincr
17110              dc(j,i+nres)=dcji
17111             enddo
17112           endif
17113 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17114 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17115 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17116 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17117 !el        write (iout,'(5x,3(3f10.5,5x))') &
17118 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17119 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17120 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17121 !el        write (iout,*)
17122       enddo
17123 !     Check omega gradient
17124       write (iout,*) &
17125        "Analytical (upper) and numerical (lower) gradient of omega"
17126       do i=2,nres-1
17127        if(itype(i,1).ne.10) then
17128                  do j=1,3
17129                   dcji=dc(j,i-1)
17130                    dc(j,i-1)=dcji+aincr
17131               call chainbuild_cart
17132               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17133                  /aincr
17134                   dc(j,i-1)=dcji
17135               dcji=dc(j,i)
17136               dc(j,i)=dcji+aincr
17137               call chainbuild_cart
17138               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17139                  /aincr
17140               dc(j,i)=dcji
17141               dcji=dc(j,i+nres)
17142               dc(j,i+nres)=dc(j,i+nres)+aincr
17143               call chainbuild_cart
17144               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17145                  /aincr
17146              dc(j,i+nres)=dcji
17147             enddo
17148           endif
17149 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17150 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17151 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17152 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17153 !el        write (iout,'(5x,3(3f10.5,5x))') &
17154 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17155 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17156 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17157 !el        write (iout,*)
17158       enddo
17159       return
17160       end subroutine checkintcartgrad
17161 !-----------------------------------------------------------------------------
17162 ! q_measure.F
17163 !-----------------------------------------------------------------------------
17164       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17165 !      implicit real*8 (a-h,o-z)
17166 !      include 'DIMENSIONS'
17167 !      include 'COMMON.IOUNITS'
17168 !      include 'COMMON.CHAIN'
17169 !      include 'COMMON.INTERACT'
17170 !      include 'COMMON.VAR'
17171       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17172       integer :: kkk,nsep=3
17173       real(kind=8) :: qm      !dist,
17174       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17175       logical :: lprn=.false.
17176       logical :: flag
17177 !      real(kind=8) :: sigm,x
17178
17179 !el      sigm(x)=0.25d0*x     ! local function
17180       qqmax=1.0d10
17181       do kkk=1,nperm
17182       qq = 0.0d0
17183       nl=0
17184        if(flag) then
17185         do il=seg1+nsep,seg2
17186           do jl=seg1,il-nsep
17187             nl=nl+1
17188             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17189                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17190                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17191             dij=dist(il,jl)
17192             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17193             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17194               nl=nl+1
17195               d0ijCM=dsqrt( &
17196                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17197                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17198                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17199               dijCM=dist(il+nres,jl+nres)
17200               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17201             endif
17202             qq = qq+qqij+qqijCM
17203           enddo
17204         enddo
17205         qq = qq/nl
17206       else
17207       do il=seg1,seg2
17208         if((seg3-il).lt.3) then
17209              secseg=il+3
17210         else
17211              secseg=seg3
17212         endif
17213           do jl=secseg,seg4
17214             nl=nl+1
17215             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17216                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17217                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17218             dij=dist(il,jl)
17219             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17220             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17221               nl=nl+1
17222               d0ijCM=dsqrt( &
17223                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17224                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17225                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17226               dijCM=dist(il+nres,jl+nres)
17227               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17228             endif
17229             qq = qq+qqij+qqijCM
17230           enddo
17231         enddo
17232       qq = qq/nl
17233       endif
17234       if (qqmax.le.qq) qqmax=qq
17235       enddo
17236       qwolynes=1.0d0-qqmax
17237       return
17238       end function qwolynes
17239 !-----------------------------------------------------------------------------
17240       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17241 !      implicit real*8 (a-h,o-z)
17242 !      include 'DIMENSIONS'
17243 !      include 'COMMON.IOUNITS'
17244 !      include 'COMMON.CHAIN'
17245 !      include 'COMMON.INTERACT'
17246 !      include 'COMMON.VAR'
17247 !      include 'COMMON.MD'
17248       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17249       integer :: nsep=3, kkk
17250 !el      real(kind=8) :: dist
17251       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17252       logical :: lprn=.false.
17253       logical :: flag
17254       real(kind=8) :: sim,dd0,fac,ddqij
17255 !el      sigm(x)=0.25d0*x           ! local function
17256       do kkk=1,nperm
17257       do i=0,nres
17258         do j=1,3
17259           dqwol(j,i)=0.0d0
17260           dxqwol(j,i)=0.0d0
17261         enddo
17262       enddo
17263       nl=0
17264        if(flag) then
17265         do il=seg1+nsep,seg2
17266           do jl=seg1,il-nsep
17267             nl=nl+1
17268             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17269                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17270                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17271             dij=dist(il,jl)
17272             sim = 1.0d0/sigm(d0ij)
17273             sim = sim*sim
17274             dd0 = dij-d0ij
17275             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17276           do k=1,3
17277               ddqij = (c(k,il)-c(k,jl))*fac
17278               dqwol(k,il)=dqwol(k,il)+ddqij
17279               dqwol(k,jl)=dqwol(k,jl)-ddqij
17280             enddo
17281
17282             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17283               nl=nl+1
17284               d0ijCM=dsqrt( &
17285                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17286                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17287                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17288               dijCM=dist(il+nres,jl+nres)
17289               sim = 1.0d0/sigm(d0ijCM)
17290               sim = sim*sim
17291               dd0=dijCM-d0ijCM
17292               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17293               do k=1,3
17294                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17295                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17296                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17297               enddo
17298             endif
17299           enddo
17300         enddo
17301        else
17302         do il=seg1,seg2
17303         if((seg3-il).lt.3) then
17304              secseg=il+3
17305         else
17306              secseg=seg3
17307         endif
17308           do jl=secseg,seg4
17309             nl=nl+1
17310             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17311                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17312                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17313             dij=dist(il,jl)
17314             sim = 1.0d0/sigm(d0ij)
17315             sim = sim*sim
17316             dd0 = dij-d0ij
17317             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17318             do k=1,3
17319               ddqij = (c(k,il)-c(k,jl))*fac
17320               dqwol(k,il)=dqwol(k,il)+ddqij
17321               dqwol(k,jl)=dqwol(k,jl)-ddqij
17322             enddo
17323             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17324               nl=nl+1
17325               d0ijCM=dsqrt( &
17326                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17327                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17328                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17329               dijCM=dist(il+nres,jl+nres)
17330               sim = 1.0d0/sigm(d0ijCM)
17331               sim=sim*sim
17332               dd0 = dijCM-d0ijCM
17333               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17334               do k=1,3
17335                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17336                dxqwol(k,il)=dxqwol(k,il)+ddqij
17337                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17338               enddo
17339             endif
17340           enddo
17341         enddo
17342       endif
17343       enddo
17344        do i=0,nres
17345          do j=1,3
17346            dqwol(j,i)=dqwol(j,i)/nl
17347            dxqwol(j,i)=dxqwol(j,i)/nl
17348          enddo
17349        enddo
17350       return
17351       end subroutine qwolynes_prim
17352 !-----------------------------------------------------------------------------
17353       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17354 !      implicit real*8 (a-h,o-z)
17355 !      include 'DIMENSIONS'
17356 !      include 'COMMON.IOUNITS'
17357 !      include 'COMMON.CHAIN'
17358 !      include 'COMMON.INTERACT'
17359 !      include 'COMMON.VAR'
17360       integer :: seg1,seg2,seg3,seg4
17361       logical :: flag
17362       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17363       real(kind=8),dimension(3,0:2*nres) :: cdummy
17364       real(kind=8) :: q1,q2
17365       real(kind=8) :: delta=1.0d-10
17366       integer :: i,j
17367
17368       do i=0,nres
17369         do j=1,3
17370           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17371           cdummy(j,i)=c(j,i)
17372           c(j,i)=c(j,i)+delta
17373           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17374           qwolan(j,i)=(q2-q1)/delta
17375           c(j,i)=cdummy(j,i)
17376         enddo
17377       enddo
17378       do i=0,nres
17379         do j=1,3
17380           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17381           cdummy(j,i+nres)=c(j,i+nres)
17382           c(j,i+nres)=c(j,i+nres)+delta
17383           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17384           qwolxan(j,i)=(q2-q1)/delta
17385           c(j,i+nres)=cdummy(j,i+nres)
17386         enddo
17387       enddo
17388 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17389 !      do i=0,nct
17390 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17391 !      enddo
17392 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17393 !      do i=0,nct
17394 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17395 !      enddo
17396       return
17397       end subroutine qwol_num
17398 !-----------------------------------------------------------------------------
17399       subroutine EconstrQ
17400 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17401 !      implicit real*8 (a-h,o-z)
17402 !      include 'DIMENSIONS'
17403 !      include 'COMMON.CONTROL'
17404 !      include 'COMMON.VAR'
17405 !      include 'COMMON.MD'
17406       use MD_data
17407 !#ifndef LANG0
17408 !      include 'COMMON.LANGEVIN'
17409 !#else
17410 !      include 'COMMON.LANGEVIN.lang0'
17411 !#endif
17412 !      include 'COMMON.CHAIN'
17413 !      include 'COMMON.DERIV'
17414 !      include 'COMMON.GEO'
17415 !      include 'COMMON.LOCAL'
17416 !      include 'COMMON.INTERACT'
17417 !      include 'COMMON.IOUNITS'
17418 !      include 'COMMON.NAMES'
17419 !      include 'COMMON.TIME1'
17420       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17421       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17422                    duconst,duxconst
17423       integer :: kstart,kend,lstart,lend,idummy
17424       real(kind=8) :: delta=1.0d-7
17425       integer :: i,j,k,ii
17426       do i=0,nres
17427          do j=1,3
17428             duconst(j,i)=0.0d0
17429             dudconst(j,i)=0.0d0
17430             duxconst(j,i)=0.0d0
17431             dudxconst(j,i)=0.0d0
17432          enddo
17433       enddo
17434       Uconst=0.0d0
17435       do i=1,nfrag
17436          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17437            idummy,idummy)
17438          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17439 ! Calculating the derivatives of Constraint energy with respect to Q
17440          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17441            qinfrag(i,iset))
17442 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17443 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17444 !         hmnum=(hm2-hm1)/delta
17445 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17446 !     &   qinfrag(i,iset))
17447 !         write(iout,*) "harmonicnum frag", hmnum
17448 ! Calculating the derivatives of Q with respect to cartesian coordinates
17449          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17450           idummy,idummy)
17451 !         write(iout,*) "dqwol "
17452 !         do ii=1,nres
17453 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17454 !         enddo
17455 !         write(iout,*) "dxqwol "
17456 !         do ii=1,nres
17457 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17458 !         enddo
17459 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17460 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17461 !     &  ,idummy,idummy)
17462 !  The gradients of Uconst in Cs
17463          do ii=0,nres
17464             do j=1,3
17465                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17466                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17467             enddo
17468          enddo
17469       enddo
17470       do i=1,npair
17471          kstart=ifrag(1,ipair(1,i,iset),iset)
17472          kend=ifrag(2,ipair(1,i,iset),iset)
17473          lstart=ifrag(1,ipair(2,i,iset),iset)
17474          lend=ifrag(2,ipair(2,i,iset),iset)
17475          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17476          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17477 !  Calculating dU/dQ
17478          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17479 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17480 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17481 !         hmnum=(hm2-hm1)/delta
17482 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17483 !     &   qinpair(i,iset))
17484 !         write(iout,*) "harmonicnum pair ", hmnum
17485 ! Calculating dQ/dXi
17486          call qwolynes_prim(kstart,kend,.false.,&
17487           lstart,lend)
17488 !         write(iout,*) "dqwol "
17489 !         do ii=1,nres
17490 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17491 !         enddo
17492 !         write(iout,*) "dxqwol "
17493 !         do ii=1,nres
17494 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17495 !        enddo
17496 ! Calculating numerical gradients
17497 !        call qwol_num(kstart,kend,.false.
17498 !     &  ,lstart,lend)
17499 ! The gradients of Uconst in Cs
17500          do ii=0,nres
17501             do j=1,3
17502                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17503                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17504             enddo
17505          enddo
17506       enddo
17507 !      write(iout,*) "Uconst inside subroutine ", Uconst
17508 ! Transforming the gradients from Cs to dCs for the backbone
17509       do i=0,nres
17510          do j=i+1,nres
17511            do k=1,3
17512              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17513            enddo
17514          enddo
17515       enddo
17516 !  Transforming the gradients from Cs to dCs for the side chains
17517       do i=1,nres
17518          do j=1,3
17519            dudxconst(j,i)=duxconst(j,i)
17520          enddo
17521       enddo
17522 !      write(iout,*) "dU/ddc backbone "
17523 !       do ii=0,nres
17524 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17525 !      enddo
17526 !      write(iout,*) "dU/ddX side chain "
17527 !      do ii=1,nres
17528 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17529 !      enddo
17530 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17531 !      call dEconstrQ_num
17532       return
17533       end subroutine EconstrQ
17534 !-----------------------------------------------------------------------------
17535       subroutine dEconstrQ_num
17536 ! Calculating numerical dUconst/ddc and dUconst/ddx
17537 !      implicit real*8 (a-h,o-z)
17538 !      include 'DIMENSIONS'
17539 !      include 'COMMON.CONTROL'
17540 !      include 'COMMON.VAR'
17541 !      include 'COMMON.MD'
17542       use MD_data
17543 !#ifndef LANG0
17544 !      include 'COMMON.LANGEVIN'
17545 !#else
17546 !      include 'COMMON.LANGEVIN.lang0'
17547 !#endif
17548 !      include 'COMMON.CHAIN'
17549 !      include 'COMMON.DERIV'
17550 !      include 'COMMON.GEO'
17551 !      include 'COMMON.LOCAL'
17552 !      include 'COMMON.INTERACT'
17553 !      include 'COMMON.IOUNITS'
17554 !      include 'COMMON.NAMES'
17555 !      include 'COMMON.TIME1'
17556       real(kind=8) :: uzap1,uzap2
17557       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17558       integer :: kstart,kend,lstart,lend,idummy
17559       real(kind=8) :: delta=1.0d-7
17560 !el local variables
17561       integer :: i,ii,j
17562 !     real(kind=8) ::
17563 !     For the backbone
17564       do i=0,nres-1
17565          do j=1,3
17566             dUcartan(j,i)=0.0d0
17567             cdummy(j,i)=dc(j,i)
17568             dc(j,i)=dc(j,i)+delta
17569             call chainbuild_cart
17570           uzap2=0.0d0
17571             do ii=1,nfrag
17572              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17573                 idummy,idummy)
17574                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17575                 qinfrag(ii,iset))
17576             enddo
17577             do ii=1,npair
17578                kstart=ifrag(1,ipair(1,ii,iset),iset)
17579                kend=ifrag(2,ipair(1,ii,iset),iset)
17580                lstart=ifrag(1,ipair(2,ii,iset),iset)
17581                lend=ifrag(2,ipair(2,ii,iset),iset)
17582                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17583                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17584                  qinpair(ii,iset))
17585             enddo
17586             dc(j,i)=cdummy(j,i)
17587             call chainbuild_cart
17588             uzap1=0.0d0
17589              do ii=1,nfrag
17590              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17591                 idummy,idummy)
17592                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17593                 qinfrag(ii,iset))
17594             enddo
17595             do ii=1,npair
17596                kstart=ifrag(1,ipair(1,ii,iset),iset)
17597                kend=ifrag(2,ipair(1,ii,iset),iset)
17598                lstart=ifrag(1,ipair(2,ii,iset),iset)
17599                lend=ifrag(2,ipair(2,ii,iset),iset)
17600                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17601                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17602                 qinpair(ii,iset))
17603             enddo
17604             ducartan(j,i)=(uzap2-uzap1)/(delta)
17605          enddo
17606       enddo
17607 ! Calculating numerical gradients for dU/ddx
17608       do i=0,nres-1
17609          duxcartan(j,i)=0.0d0
17610          do j=1,3
17611             cdummy(j,i)=dc(j,i+nres)
17612             dc(j,i+nres)=dc(j,i+nres)+delta
17613             call chainbuild_cart
17614           uzap2=0.0d0
17615             do ii=1,nfrag
17616              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17617                 idummy,idummy)
17618                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17619                 qinfrag(ii,iset))
17620             enddo
17621             do ii=1,npair
17622                kstart=ifrag(1,ipair(1,ii,iset),iset)
17623                kend=ifrag(2,ipair(1,ii,iset),iset)
17624                lstart=ifrag(1,ipair(2,ii,iset),iset)
17625                lend=ifrag(2,ipair(2,ii,iset),iset)
17626                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17627                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17628                 qinpair(ii,iset))
17629             enddo
17630             dc(j,i+nres)=cdummy(j,i)
17631             call chainbuild_cart
17632             uzap1=0.0d0
17633              do ii=1,nfrag
17634                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17635                 ifrag(2,ii,iset),.true.,idummy,idummy)
17636                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17637                 qinfrag(ii,iset))
17638             enddo
17639             do ii=1,npair
17640                kstart=ifrag(1,ipair(1,ii,iset),iset)
17641                kend=ifrag(2,ipair(1,ii,iset),iset)
17642                lstart=ifrag(1,ipair(2,ii,iset),iset)
17643                lend=ifrag(2,ipair(2,ii,iset),iset)
17644                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17645                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17646                 qinpair(ii,iset))
17647             enddo
17648             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17649          enddo
17650       enddo
17651       write(iout,*) "Numerical dUconst/ddc backbone "
17652       do ii=0,nres
17653         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17654       enddo
17655 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17656 !      do ii=1,nres
17657 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17658 !      enddo
17659       return
17660       end subroutine dEconstrQ_num
17661 !-----------------------------------------------------------------------------
17662 ! ssMD.F
17663 !-----------------------------------------------------------------------------
17664       subroutine check_energies
17665
17666 !      use random, only: ran_number
17667
17668 !      implicit none
17669 !     Includes
17670 !      include 'DIMENSIONS'
17671 !      include 'COMMON.CHAIN'
17672 !      include 'COMMON.VAR'
17673 !      include 'COMMON.IOUNITS'
17674 !      include 'COMMON.SBRIDGE'
17675 !      include 'COMMON.LOCAL'
17676 !      include 'COMMON.GEO'
17677
17678 !     External functions
17679 !EL      double precision ran_number
17680 !EL      external ran_number
17681
17682 !     Local variables
17683       integer :: i,j,k,l,lmax,p,pmax
17684       real(kind=8) :: rmin,rmax
17685       real(kind=8) :: eij
17686
17687       real(kind=8) :: d
17688       real(kind=8) :: wi,rij,tj,pj
17689 !      return
17690
17691       i=5
17692       j=14
17693
17694       d=dsc(1)
17695       rmin=2.0D0
17696       rmax=12.0D0
17697
17698       lmax=10000
17699       pmax=1
17700
17701       do k=1,3
17702         c(k,i)=0.0D0
17703         c(k,j)=0.0D0
17704         c(k,nres+i)=0.0D0
17705         c(k,nres+j)=0.0D0
17706       enddo
17707
17708       do l=1,lmax
17709
17710 !t        wi=ran_number(0.0D0,pi)
17711 !        wi=ran_number(0.0D0,pi/6.0D0)
17712 !        wi=0.0D0
17713 !t        tj=ran_number(0.0D0,pi)
17714 !t        pj=ran_number(0.0D0,pi)
17715 !        pj=ran_number(0.0D0,pi/6.0D0)
17716 !        pj=0.0D0
17717
17718         do p=1,pmax
17719 !t           rij=ran_number(rmin,rmax)
17720
17721            c(1,j)=d*sin(pj)*cos(tj)
17722            c(2,j)=d*sin(pj)*sin(tj)
17723            c(3,j)=d*cos(pj)
17724
17725            c(3,nres+i)=-rij
17726
17727            c(1,i)=d*sin(wi)
17728            c(3,i)=-rij-d*cos(wi)
17729
17730            do k=1,3
17731               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17732               dc_norm(k,nres+i)=dc(k,nres+i)/d
17733               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17734               dc_norm(k,nres+j)=dc(k,nres+j)/d
17735            enddo
17736
17737            call dyn_ssbond_ene(i,j,eij)
17738         enddo
17739       enddo
17740       call exit(1)
17741       return
17742       end subroutine check_energies
17743 !-----------------------------------------------------------------------------
17744       subroutine dyn_ssbond_ene(resi,resj,eij)
17745 !      implicit none
17746 !      Includes
17747       use calc_data
17748       use comm_sschecks
17749 !      include 'DIMENSIONS'
17750 !      include 'COMMON.SBRIDGE'
17751 !      include 'COMMON.CHAIN'
17752 !      include 'COMMON.DERIV'
17753 !      include 'COMMON.LOCAL'
17754 !      include 'COMMON.INTERACT'
17755 !      include 'COMMON.VAR'
17756 !      include 'COMMON.IOUNITS'
17757 !      include 'COMMON.CALC'
17758 #ifndef CLUST
17759 #ifndef WHAM
17760        use MD_data
17761 !      include 'COMMON.MD'
17762 !      use MD, only: totT,t_bath
17763 #endif
17764 #endif
17765 !     External functions
17766 !EL      double precision h_base
17767 !EL      external h_base
17768
17769 !     Input arguments
17770       integer :: resi,resj
17771
17772 !     Output arguments
17773       real(kind=8) :: eij
17774
17775 !     Local variables
17776       logical :: havebond
17777       integer itypi,itypj
17778       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17779       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17780       real(kind=8),dimension(3) :: dcosom1,dcosom2
17781       real(kind=8) :: ed
17782       real(kind=8) :: pom1,pom2
17783       real(kind=8) :: ljA,ljB,ljXs
17784       real(kind=8),dimension(1:3) :: d_ljB
17785       real(kind=8) :: ssA,ssB,ssC,ssXs
17786       real(kind=8) :: ssxm,ljxm,ssm,ljm
17787       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17788       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17789       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17790 !-------FIRST METHOD
17791       real(kind=8) :: xm
17792       real(kind=8),dimension(1:3) :: d_xm
17793 !-------END FIRST METHOD
17794 !-------SECOND METHOD
17795 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17796 !-------END SECOND METHOD
17797
17798 !-------TESTING CODE
17799 !el      logical :: checkstop,transgrad
17800 !el      common /sschecks/ checkstop,transgrad
17801
17802       integer :: icheck,nicheck,jcheck,njcheck
17803       real(kind=8),dimension(-1:1) :: echeck
17804       real(kind=8) :: deps,ssx0,ljx0
17805 !-------END TESTING CODE
17806
17807       eij=0.0d0
17808       i=resi
17809       j=resj
17810
17811 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17812 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17813
17814       itypi=itype(i,1)
17815       dxi=dc_norm(1,nres+i)
17816       dyi=dc_norm(2,nres+i)
17817       dzi=dc_norm(3,nres+i)
17818       dsci_inv=vbld_inv(i+nres)
17819
17820       itypj=itype(j,1)
17821       xj=c(1,nres+j)-c(1,nres+i)
17822       yj=c(2,nres+j)-c(2,nres+i)
17823       zj=c(3,nres+j)-c(3,nres+i)
17824       dxj=dc_norm(1,nres+j)
17825       dyj=dc_norm(2,nres+j)
17826       dzj=dc_norm(3,nres+j)
17827       dscj_inv=vbld_inv(j+nres)
17828
17829       chi1=chi(itypi,itypj)
17830       chi2=chi(itypj,itypi)
17831       chi12=chi1*chi2
17832       chip1=chip(itypi)
17833       chip2=chip(itypj)
17834       chip12=chip1*chip2
17835       alf1=alp(itypi)
17836       alf2=alp(itypj)
17837       alf12=0.5D0*(alf1+alf2)
17838
17839       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17840       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17841 !     The following are set in sc_angular
17842 !      erij(1)=xj*rij
17843 !      erij(2)=yj*rij
17844 !      erij(3)=zj*rij
17845 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17846 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17847 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17848       call sc_angular
17849       rij=1.0D0/rij  ! Reset this so it makes sense
17850
17851       sig0ij=sigma(itypi,itypj)
17852       sig=sig0ij*dsqrt(1.0D0/sigsq)
17853
17854       ljXs=sig-sig0ij
17855       ljA=eps1*eps2rt**2*eps3rt**2
17856       ljB=ljA*bb_aq(itypi,itypj)
17857       ljA=ljA*aa_aq(itypi,itypj)
17858       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17859
17860       ssXs=d0cm
17861       deltat1=1.0d0-om1
17862       deltat2=1.0d0+om2
17863       deltat12=om2-om1+2.0d0
17864       cosphi=om12-om1*om2
17865       ssA=akcm
17866       ssB=akct*deltat12
17867       ssC=ss_depth &
17868            +akth*(deltat1*deltat1+deltat2*deltat2) &
17869            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17870       ssxm=ssXs-0.5D0*ssB/ssA
17871
17872 !-------TESTING CODE
17873 !$$$c     Some extra output
17874 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17875 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17876 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17877 !$$$      if (ssx0.gt.0.0d0) then
17878 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17879 !$$$      else
17880 !$$$        ssx0=ssxm
17881 !$$$      endif
17882 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17883 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17884 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17885 !$$$      return
17886 !-------END TESTING CODE
17887
17888 !-------TESTING CODE
17889 !     Stop and plot energy and derivative as a function of distance
17890       if (checkstop) then
17891         ssm=ssC-0.25D0*ssB*ssB/ssA
17892         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17893         if (ssm.lt.ljm .and. &
17894              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17895           nicheck=1000
17896           njcheck=1
17897           deps=0.5d-7
17898         else
17899           checkstop=.false.
17900         endif
17901       endif
17902       if (.not.checkstop) then
17903         nicheck=0
17904         njcheck=-1
17905       endif
17906
17907       do icheck=0,nicheck
17908       do jcheck=-1,njcheck
17909       if (checkstop) rij=(ssxm-1.0d0)+ &
17910              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17911 !-------END TESTING CODE
17912
17913       if (rij.gt.ljxm) then
17914         havebond=.false.
17915         ljd=rij-ljXs
17916         fac=(1.0D0/ljd)**expon
17917         e1=fac*fac*aa_aq(itypi,itypj)
17918         e2=fac*bb_aq(itypi,itypj)
17919         eij=eps1*eps2rt*eps3rt*(e1+e2)
17920         eps2der=eij*eps3rt
17921         eps3der=eij*eps2rt
17922         eij=eij*eps2rt*eps3rt
17923
17924         sigder=-sig/sigsq
17925         e1=e1*eps1*eps2rt**2*eps3rt**2
17926         ed=-expon*(e1+eij)/ljd
17927         sigder=ed*sigder
17928         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17929         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17930         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
17931              -2.0D0*alf12*eps3der+sigder*sigsq_om12
17932       else if (rij.lt.ssxm) then
17933         havebond=.true.
17934         ssd=rij-ssXs
17935         eij=ssA*ssd*ssd+ssB*ssd+ssC
17936
17937         ed=2*akcm*ssd+akct*deltat12
17938         pom1=akct*ssd
17939         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
17940         eom1=-2*akth*deltat1-pom1-om2*pom2
17941         eom2= 2*akth*deltat2+pom1-om1*pom2
17942         eom12=pom2
17943       else
17944         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
17945
17946         d_ssxm(1)=0.5D0*akct/ssA
17947         d_ssxm(2)=-d_ssxm(1)
17948         d_ssxm(3)=0.0D0
17949
17950         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
17951         d_ljxm(2)=d_ljxm(1)*sigsq_om2
17952         d_ljxm(3)=d_ljxm(1)*sigsq_om12
17953         d_ljxm(1)=d_ljxm(1)*sigsq_om1
17954
17955 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17956         xm=0.5d0*(ssxm+ljxm)
17957         do k=1,3
17958           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
17959         enddo
17960         if (rij.lt.xm) then
17961           havebond=.true.
17962           ssm=ssC-0.25D0*ssB*ssB/ssA
17963           d_ssm(1)=0.5D0*akct*ssB/ssA
17964           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17965           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17966           d_ssm(3)=omega
17967           f1=(rij-xm)/(ssxm-xm)
17968           f2=(rij-ssxm)/(xm-ssxm)
17969           h1=h_base(f1,hd1)
17970           h2=h_base(f2,hd2)
17971           eij=ssm*h1+Ht*h2
17972           delta_inv=1.0d0/(xm-ssxm)
17973           deltasq_inv=delta_inv*delta_inv
17974           fac=ssm*hd1-Ht*hd2
17975           fac1=deltasq_inv*fac*(xm-rij)
17976           fac2=deltasq_inv*fac*(rij-ssxm)
17977           ed=delta_inv*(Ht*hd2-ssm*hd1)
17978           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
17979           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
17980           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
17981         else
17982           havebond=.false.
17983           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17984           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
17985           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
17986           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
17987                alf12/eps3rt)
17988           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
17989           f1=(rij-ljxm)/(xm-ljxm)
17990           f2=(rij-xm)/(ljxm-xm)
17991           h1=h_base(f1,hd1)
17992           h2=h_base(f2,hd2)
17993           eij=Ht*h1+ljm*h2
17994           delta_inv=1.0d0/(ljxm-xm)
17995           deltasq_inv=delta_inv*delta_inv
17996           fac=Ht*hd1-ljm*hd2
17997           fac1=deltasq_inv*fac*(ljxm-rij)
17998           fac2=deltasq_inv*fac*(rij-xm)
17999           ed=delta_inv*(ljm*hd2-Ht*hd1)
18000           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18001           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18002           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18003         endif
18004 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18005
18006 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18007 !$$$        ssd=rij-ssXs
18008 !$$$        ljd=rij-ljXs
18009 !$$$        fac1=rij-ljxm
18010 !$$$        fac2=rij-ssxm
18011 !$$$
18012 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18013 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18014 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18015 !$$$
18016 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18017 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18018 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18019 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18020 !$$$        d_ssm(3)=omega
18021 !$$$
18022 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18023 !$$$        do k=1,3
18024 !$$$          d_ljm(k)=ljm*d_ljB(k)
18025 !$$$        enddo
18026 !$$$        ljm=ljm*ljB
18027 !$$$
18028 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18029 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18030 !$$$        d_ss(2)=akct*ssd
18031 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18032 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18033 !$$$        d_ss(3)=omega
18034 !$$$
18035 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18036 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18037 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18038 !$$$        do k=1,3
18039 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18040 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18041 !$$$        enddo
18042 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18043 !$$$
18044 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18045 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18046 !$$$        h1=h_base(f1,hd1)
18047 !$$$        h2=h_base(f2,hd2)
18048 !$$$        eij=ss*h1+ljf*h2
18049 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18050 !$$$        deltasq_inv=delta_inv*delta_inv
18051 !$$$        fac=ljf*hd2-ss*hd1
18052 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18053 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18054 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18055 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18056 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18057 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18058 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18059 !$$$
18060 !$$$        havebond=.false.
18061 !$$$        if (ed.gt.0.0d0) havebond=.true.
18062 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18063
18064       endif
18065
18066       if (havebond) then
18067 !#ifndef CLUST
18068 !#ifndef WHAM
18069 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18070 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18071 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18072 !        endif
18073 !#endif
18074 !#endif
18075         dyn_ssbond_ij(i,j)=eij
18076       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18077         dyn_ssbond_ij(i,j)=1.0d300
18078 !#ifndef CLUST
18079 !#ifndef WHAM
18080 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18081 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18082 !#endif
18083 !#endif
18084       endif
18085
18086 !-------TESTING CODE
18087 !el      if (checkstop) then
18088         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18089              "CHECKSTOP",rij,eij,ed
18090         echeck(jcheck)=eij
18091 !el      endif
18092       enddo
18093       if (checkstop) then
18094         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18095       endif
18096       enddo
18097       if (checkstop) then
18098         transgrad=.true.
18099         checkstop=.false.
18100       endif
18101 !-------END TESTING CODE
18102
18103       do k=1,3
18104         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18105         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18106       enddo
18107       do k=1,3
18108         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18109       enddo
18110       do k=1,3
18111         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18112              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18113              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18114         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18115              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18116              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18117       enddo
18118 !grad      do k=i,j-1
18119 !grad        do l=1,3
18120 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18121 !grad        enddo
18122 !grad      enddo
18123
18124       do l=1,3
18125         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18126         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18127       enddo
18128
18129       return
18130       end subroutine dyn_ssbond_ene
18131 !--------------------------------------------------------------------------
18132          subroutine triple_ssbond_ene(resi,resj,resk,eij)
18133 !      implicit none
18134 !      Includes
18135       use calc_data
18136       use comm_sschecks
18137 !      include 'DIMENSIONS'
18138 !      include 'COMMON.SBRIDGE'
18139 !      include 'COMMON.CHAIN'
18140 !      include 'COMMON.DERIV'
18141 !      include 'COMMON.LOCAL'
18142 !      include 'COMMON.INTERACT'
18143 !      include 'COMMON.VAR'
18144 !      include 'COMMON.IOUNITS'
18145 !      include 'COMMON.CALC'
18146 #ifndef CLUST
18147 #ifndef WHAM
18148        use MD_data
18149 !      include 'COMMON.MD'
18150 !      use MD, only: totT,t_bath
18151 #endif
18152 #endif
18153       double precision h_base
18154       external h_base
18155
18156 !c     Input arguments
18157       integer resi,resj,resk,m,itypi,itypj,itypk
18158
18159 !c     Output arguments
18160       double precision eij,eij1,eij2,eij3
18161
18162 !c     Local variables
18163       logical havebond
18164 !c      integer itypi,itypj,k,l
18165       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18166       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18167       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18168       double precision sig0ij,ljd,sig,fac,e1,e2
18169       double precision dcosom1(3),dcosom2(3),ed
18170       double precision pom1,pom2
18171       double precision ljA,ljB,ljXs
18172       double precision d_ljB(1:3)
18173       double precision ssA,ssB,ssC,ssXs
18174       double precision ssxm,ljxm,ssm,ljm
18175       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18176       eij=0.0
18177       if (dtriss.eq.0) return
18178       i=resi
18179       j=resj
18180       k=resk
18181 !C      write(iout,*) resi,resj,resk
18182       itypi=itype(i,1)
18183       dxi=dc_norm(1,nres+i)
18184       dyi=dc_norm(2,nres+i)
18185       dzi=dc_norm(3,nres+i)
18186       dsci_inv=vbld_inv(i+nres)
18187       xi=c(1,nres+i)
18188       yi=c(2,nres+i)
18189       zi=c(3,nres+i)
18190       itypj=itype(j,1)
18191       xj=c(1,nres+j)
18192       yj=c(2,nres+j)
18193       zj=c(3,nres+j)
18194
18195       dxj=dc_norm(1,nres+j)
18196       dyj=dc_norm(2,nres+j)
18197       dzj=dc_norm(3,nres+j)
18198       dscj_inv=vbld_inv(j+nres)
18199       itypk=itype(k,1)
18200       xk=c(1,nres+k)
18201       yk=c(2,nres+k)
18202       zk=c(3,nres+k)
18203
18204       dxk=dc_norm(1,nres+k)
18205       dyk=dc_norm(2,nres+k)
18206       dzk=dc_norm(3,nres+k)
18207       dscj_inv=vbld_inv(k+nres)
18208       xij=xj-xi
18209       xik=xk-xi
18210       xjk=xk-xj
18211       yij=yj-yi
18212       yik=yk-yi
18213       yjk=yk-yj
18214       zij=zj-zi
18215       zik=zk-zi
18216       zjk=zk-zj
18217       rrij=(xij*xij+yij*yij+zij*zij)
18218       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18219       rrik=(xik*xik+yik*yik+zik*zik)
18220       rik=dsqrt(rrik)
18221       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18222       rjk=dsqrt(rrjk)
18223 !C there are three combination of distances for each trisulfide bonds
18224 !C The first case the ith atom is the center
18225 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18226 !C distance y is second distance the a,b,c,d are parameters derived for
18227 !C this problem d parameter was set as a penalty currenlty set to 1.
18228       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18229       eij1=0.0d0
18230       else
18231       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18232       endif
18233 !C second case jth atom is center
18234       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18235       eij2=0.0d0
18236       else
18237       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18238       endif
18239 !C the third case kth atom is the center
18240       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18241       eij3=0.0d0
18242       else
18243       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18244       endif
18245 !C      eij2=0.0
18246 !C      eij3=0.0
18247 !C      eij1=0.0
18248       eij=eij1+eij2+eij3
18249 !C      write(iout,*)i,j,k,eij
18250 !C The energy penalty calculated now time for the gradient part
18251 !C derivative over rij
18252       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18253       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18254             gg(1)=xij*fac/rij
18255             gg(2)=yij*fac/rij
18256             gg(3)=zij*fac/rij
18257       do m=1,3
18258         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18259         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18260       enddo
18261
18262       do l=1,3
18263         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18264         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18265       enddo
18266 !C now derivative over rik
18267       fac=-eij1**2/dtriss* &
18268       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18269       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18270             gg(1)=xik*fac/rik
18271             gg(2)=yik*fac/rik
18272             gg(3)=zik*fac/rik
18273       do m=1,3
18274         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18275         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18276       enddo
18277       do l=1,3
18278         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18279         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18280       enddo
18281 !C now derivative over rjk
18282       fac=-eij2**2/dtriss* &
18283       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18284       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18285             gg(1)=xjk*fac/rjk
18286             gg(2)=yjk*fac/rjk
18287             gg(3)=zjk*fac/rjk
18288       do m=1,3
18289         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18290         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18291       enddo
18292       do l=1,3
18293         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18294         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18295       enddo
18296       return
18297       end subroutine triple_ssbond_ene
18298
18299
18300
18301 !-----------------------------------------------------------------------------
18302       real(kind=8) function h_base(x,deriv)
18303 !     A smooth function going 0->1 in range [0,1]
18304 !     It should NOT be called outside range [0,1], it will not work there.
18305       implicit none
18306
18307 !     Input arguments
18308       real(kind=8) :: x
18309
18310 !     Output arguments
18311       real(kind=8) :: deriv
18312
18313 !     Local variables
18314       real(kind=8) :: xsq
18315
18316
18317 !     Two parabolas put together.  First derivative zero at extrema
18318 !$$$      if (x.lt.0.5D0) then
18319 !$$$        h_base=2.0D0*x*x
18320 !$$$        deriv=4.0D0*x
18321 !$$$      else
18322 !$$$        deriv=1.0D0-x
18323 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18324 !$$$        deriv=4.0D0*deriv
18325 !$$$      endif
18326
18327 !     Third degree polynomial.  First derivative zero at extrema
18328       h_base=x*x*(3.0d0-2.0d0*x)
18329       deriv=6.0d0*x*(1.0d0-x)
18330
18331 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18332 !$$$      xsq=x*x
18333 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18334 !$$$      deriv=x-1.0d0
18335 !$$$      deriv=deriv*deriv
18336 !$$$      deriv=30.0d0*xsq*deriv
18337
18338       return
18339       end function h_base
18340 !-----------------------------------------------------------------------------
18341       subroutine dyn_set_nss
18342 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18343 !      implicit none
18344       use MD_data, only: totT,t_bath
18345 !     Includes
18346 !      include 'DIMENSIONS'
18347 #ifdef MPI
18348       include "mpif.h"
18349 #endif
18350 !      include 'COMMON.SBRIDGE'
18351 !      include 'COMMON.CHAIN'
18352 !      include 'COMMON.IOUNITS'
18353 !      include 'COMMON.SETUP'
18354 !      include 'COMMON.MD'
18355 !     Local variables
18356       real(kind=8) :: emin
18357       integer :: i,j,imin,ierr
18358       integer :: diff,allnss,newnss
18359       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18360                 newihpb,newjhpb
18361       logical :: found
18362       integer,dimension(0:nfgtasks) :: i_newnss
18363       integer,dimension(0:nfgtasks) :: displ
18364       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18365       integer :: g_newnss
18366
18367       allnss=0
18368       do i=1,nres-1
18369         do j=i+1,nres
18370           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18371             allnss=allnss+1
18372             allflag(allnss)=0
18373             allihpb(allnss)=i
18374             alljhpb(allnss)=j
18375           endif
18376         enddo
18377       enddo
18378
18379 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18380
18381  1    emin=1.0d300
18382       do i=1,allnss
18383         if (allflag(i).eq.0 .and. &
18384              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18385           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18386           imin=i
18387         endif
18388       enddo
18389       if (emin.lt.1.0d300) then
18390         allflag(imin)=1
18391         do i=1,allnss
18392           if (allflag(i).eq.0 .and. &
18393                (allihpb(i).eq.allihpb(imin) .or. &
18394                alljhpb(i).eq.allihpb(imin) .or. &
18395                allihpb(i).eq.alljhpb(imin) .or. &
18396                alljhpb(i).eq.alljhpb(imin))) then
18397             allflag(i)=-1
18398           endif
18399         enddo
18400         goto 1
18401       endif
18402
18403 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18404
18405       newnss=0
18406       do i=1,allnss
18407         if (allflag(i).eq.1) then
18408           newnss=newnss+1
18409           newihpb(newnss)=allihpb(i)
18410           newjhpb(newnss)=alljhpb(i)
18411         endif
18412       enddo
18413
18414 #ifdef MPI
18415       if (nfgtasks.gt.1)then
18416
18417         call MPI_Reduce(newnss,g_newnss,1,&
18418           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18419         call MPI_Gather(newnss,1,MPI_INTEGER,&
18420                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18421         displ(0)=0
18422         do i=1,nfgtasks-1,1
18423           displ(i)=i_newnss(i-1)+displ(i-1)
18424         enddo
18425         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18426                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18427                          king,FG_COMM,IERR)
18428         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18429                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18430                          king,FG_COMM,IERR)
18431         if(fg_rank.eq.0) then
18432 !         print *,'g_newnss',g_newnss
18433 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18434 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18435          newnss=g_newnss
18436          do i=1,newnss
18437           newihpb(i)=g_newihpb(i)
18438           newjhpb(i)=g_newjhpb(i)
18439          enddo
18440         endif
18441       endif
18442 #endif
18443
18444       diff=newnss-nss
18445
18446 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18447 !       print *,newnss,nss,maxdim
18448       do i=1,nss
18449         found=.false.
18450 !        print *,newnss
18451         do j=1,newnss
18452 !!          print *,j
18453           if (idssb(i).eq.newihpb(j) .and. &
18454                jdssb(i).eq.newjhpb(j)) found=.true.
18455         enddo
18456 #ifndef CLUST
18457 #ifndef WHAM
18458 !        write(iout,*) "found",found,i,j
18459         if (.not.found.and.fg_rank.eq.0) &
18460             write(iout,'(a15,f12.2,f8.1,2i5)') &
18461              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18462 #endif
18463 #endif
18464       enddo
18465
18466       do i=1,newnss
18467         found=.false.
18468         do j=1,nss
18469 !          print *,i,j
18470           if (newihpb(i).eq.idssb(j) .and. &
18471                newjhpb(i).eq.jdssb(j)) found=.true.
18472         enddo
18473 #ifndef CLUST
18474 #ifndef WHAM
18475 !        write(iout,*) "found",found,i,j
18476         if (.not.found.and.fg_rank.eq.0) &
18477             write(iout,'(a15,f12.2,f8.1,2i5)') &
18478              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18479 #endif
18480 #endif
18481       enddo
18482
18483       nss=newnss
18484       do i=1,nss
18485         idssb(i)=newihpb(i)
18486         jdssb(i)=newjhpb(i)
18487       enddo
18488
18489       return
18490       end subroutine dyn_set_nss
18491 ! Lipid transfer energy function
18492       subroutine Eliptransfer(eliptran)
18493 !C this is done by Adasko
18494 !C      print *,"wchodze"
18495 !C structure of box:
18496 !C      water
18497 !C--bordliptop-- buffore starts
18498 !C--bufliptop--- here true lipid starts
18499 !C      lipid
18500 !C--buflipbot--- lipid ends buffore starts
18501 !C--bordlipbot--buffore ends
18502       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18503       integer :: i
18504       eliptran=0.0
18505 !      print *, "I am in eliptran"
18506       do i=ilip_start,ilip_end
18507 !C       do i=1,1
18508         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18509          cycle
18510
18511         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18512         if (positi.le.0.0) positi=positi+boxzsize
18513 !C        print *,i
18514 !C first for peptide groups
18515 !c for each residue check if it is in lipid or lipid water border area
18516        if ((positi.gt.bordlipbot)  &
18517       .and.(positi.lt.bordliptop)) then
18518 !C the energy transfer exist
18519         if (positi.lt.buflipbot) then
18520 !C what fraction I am in
18521          fracinbuf=1.0d0-      &
18522              ((positi-bordlipbot)/lipbufthick)
18523 !C lipbufthick is thickenes of lipid buffore
18524          sslip=sscalelip(fracinbuf)
18525          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18526          eliptran=eliptran+sslip*pepliptran
18527          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18528          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18529 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18530
18531 !C        print *,"doing sccale for lower part"
18532 !C         print *,i,sslip,fracinbuf,ssgradlip
18533         elseif (positi.gt.bufliptop) then
18534          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18535          sslip=sscalelip(fracinbuf)
18536          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18537          eliptran=eliptran+sslip*pepliptran
18538          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18539          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18540 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18541 !C          print *, "doing sscalefor top part"
18542 !C         print *,i,sslip,fracinbuf,ssgradlip
18543         else
18544          eliptran=eliptran+pepliptran
18545 !C         print *,"I am in true lipid"
18546         endif
18547 !C       else
18548 !C       eliptran=elpitran+0.0 ! I am in water
18549        endif
18550        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18551        enddo
18552 ! here starts the side chain transfer
18553        do i=ilip_start,ilip_end
18554         if (itype(i,1).eq.ntyp1) cycle
18555         positi=(mod(c(3,i+nres),boxzsize))
18556         if (positi.le.0) positi=positi+boxzsize
18557 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18558 !c for each residue check if it is in lipid or lipid water border area
18559 !C       respos=mod(c(3,i+nres),boxzsize)
18560 !C       print *,positi,bordlipbot,buflipbot
18561        if ((positi.gt.bordlipbot) &
18562        .and.(positi.lt.bordliptop)) then
18563 !C the energy transfer exist
18564         if (positi.lt.buflipbot) then
18565          fracinbuf=1.0d0-   &
18566            ((positi-bordlipbot)/lipbufthick)
18567 !C lipbufthick is thickenes of lipid buffore
18568          sslip=sscalelip(fracinbuf)
18569          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18570          eliptran=eliptran+sslip*liptranene(itype(i,1))
18571          gliptranx(3,i)=gliptranx(3,i) &
18572       +ssgradlip*liptranene(itype(i,1))
18573          gliptranc(3,i-1)= gliptranc(3,i-1) &
18574       +ssgradlip*liptranene(itype(i,1))
18575 !C         print *,"doing sccale for lower part"
18576         elseif (positi.gt.bufliptop) then
18577          fracinbuf=1.0d0-  &
18578       ((bordliptop-positi)/lipbufthick)
18579          sslip=sscalelip(fracinbuf)
18580          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18581          eliptran=eliptran+sslip*liptranene(itype(i,1))
18582          gliptranx(3,i)=gliptranx(3,i)  &
18583        +ssgradlip*liptranene(itype(i,1))
18584          gliptranc(3,i-1)= gliptranc(3,i-1) &
18585       +ssgradlip*liptranene(itype(i,1))
18586 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18587         else
18588          eliptran=eliptran+liptranene(itype(i,1))
18589 !C         print *,"I am in true lipid"
18590         endif
18591         endif ! if in lipid or buffor
18592 !C       else
18593 !C       eliptran=elpitran+0.0 ! I am in water
18594         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18595        enddo
18596        return
18597        end  subroutine Eliptransfer
18598 !----------------------------------NANO FUNCTIONS
18599 !C-----------------------------------------------------------------------
18600 !C-----------------------------------------------------------
18601 !C This subroutine is to mimic the histone like structure but as well can be
18602 !C utilizet to nanostructures (infinit) small modification has to be used to
18603 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18604 !C gradient has to be modified at the ends
18605 !C The energy function is Kihara potential
18606 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18607 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18608 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18609 !C simple Kihara potential
18610       subroutine calctube(Etube)
18611       real(kind=8),dimension(3) :: vectube
18612       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18613        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18614        sc_aa_tube,sc_bb_tube
18615       integer :: i,j,iti
18616       Etube=0.0d0
18617       do i=itube_start,itube_end
18618         enetube(i)=0.0d0
18619         enetube(i+nres)=0.0d0
18620       enddo
18621 !C first we calculate the distance from tube center
18622 !C for UNRES
18623        do i=itube_start,itube_end
18624 !C lets ommit dummy atoms for now
18625        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18626 !C now calculate distance from center of tube and direction vectors
18627       xmin=boxxsize
18628       ymin=boxysize
18629 ! Find minimum distance in periodic box
18630         do j=-1,1
18631          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18632          vectube(1)=vectube(1)+boxxsize*j
18633          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18634          vectube(2)=vectube(2)+boxysize*j
18635          xminact=abs(vectube(1)-tubecenter(1))
18636          yminact=abs(vectube(2)-tubecenter(2))
18637            if (xmin.gt.xminact) then
18638             xmin=xminact
18639             xtemp=vectube(1)
18640            endif
18641            if (ymin.gt.yminact) then
18642              ymin=yminact
18643              ytemp=vectube(2)
18644             endif
18645          enddo
18646       vectube(1)=xtemp
18647       vectube(2)=ytemp
18648       vectube(1)=vectube(1)-tubecenter(1)
18649       vectube(2)=vectube(2)-tubecenter(2)
18650
18651 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18652 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18653
18654 !C as the tube is infinity we do not calculate the Z-vector use of Z
18655 !C as chosen axis
18656       vectube(3)=0.0d0
18657 !C now calculte the distance
18658        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18659 !C now normalize vector
18660       vectube(1)=vectube(1)/tub_r
18661       vectube(2)=vectube(2)/tub_r
18662 !C calculte rdiffrence between r and r0
18663       rdiff=tub_r-tubeR0
18664 !C and its 6 power
18665       rdiff6=rdiff**6.0d0
18666 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18667        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18668 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18669 !C       print *,rdiff,rdiff6,pep_aa_tube
18670 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18671 !C now we calculate gradient
18672        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18673             6.0d0*pep_bb_tube)/rdiff6/rdiff
18674 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18675 !C     &rdiff,fac
18676 !C now direction of gg_tube vector
18677         do j=1,3
18678         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18679         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18680         enddo
18681         enddo
18682 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18683 !C        print *,gg_tube(1,0),"TU"
18684
18685
18686        do i=itube_start,itube_end
18687 !C Lets not jump over memory as we use many times iti
18688          iti=itype(i,1)
18689 !C lets ommit dummy atoms for now
18690          if ((iti.eq.ntyp1)  &
18691 !C in UNRES uncomment the line below as GLY has no side-chain...
18692 !C      .or.(iti.eq.10)
18693         ) cycle
18694       xmin=boxxsize
18695       ymin=boxysize
18696         do j=-1,1
18697          vectube(1)=mod((c(1,i+nres)),boxxsize)
18698          vectube(1)=vectube(1)+boxxsize*j
18699          vectube(2)=mod((c(2,i+nres)),boxysize)
18700          vectube(2)=vectube(2)+boxysize*j
18701
18702          xminact=abs(vectube(1)-tubecenter(1))
18703          yminact=abs(vectube(2)-tubecenter(2))
18704            if (xmin.gt.xminact) then
18705             xmin=xminact
18706             xtemp=vectube(1)
18707            endif
18708            if (ymin.gt.yminact) then
18709              ymin=yminact
18710              ytemp=vectube(2)
18711             endif
18712          enddo
18713       vectube(1)=xtemp
18714       vectube(2)=ytemp
18715 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18716 !C     &     tubecenter(2)
18717       vectube(1)=vectube(1)-tubecenter(1)
18718       vectube(2)=vectube(2)-tubecenter(2)
18719
18720 !C as the tube is infinity we do not calculate the Z-vector use of Z
18721 !C as chosen axis
18722       vectube(3)=0.0d0
18723 !C now calculte the distance
18724        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18725 !C now normalize vector
18726       vectube(1)=vectube(1)/tub_r
18727       vectube(2)=vectube(2)/tub_r
18728
18729 !C calculte rdiffrence between r and r0
18730       rdiff=tub_r-tubeR0
18731 !C and its 6 power
18732       rdiff6=rdiff**6.0d0
18733 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18734        sc_aa_tube=sc_aa_tube_par(iti)
18735        sc_bb_tube=sc_bb_tube_par(iti)
18736        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18737        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18738              6.0d0*sc_bb_tube/rdiff6/rdiff
18739 !C now direction of gg_tube vector
18740          do j=1,3
18741           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18742           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18743          enddo
18744         enddo
18745         do i=itube_start,itube_end
18746           Etube=Etube+enetube(i)+enetube(i+nres)
18747         enddo
18748 !C        print *,"ETUBE", etube
18749         return
18750         end subroutine calctube
18751 !C TO DO 1) add to total energy
18752 !C       2) add to gradient summation
18753 !C       3) add reading parameters (AND of course oppening of PARAM file)
18754 !C       4) add reading the center of tube
18755 !C       5) add COMMONs
18756 !C       6) add to zerograd
18757 !C       7) allocate matrices
18758
18759
18760 !C-----------------------------------------------------------------------
18761 !C-----------------------------------------------------------
18762 !C This subroutine is to mimic the histone like structure but as well can be
18763 !C utilizet to nanostructures (infinit) small modification has to be used to
18764 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18765 !C gradient has to be modified at the ends
18766 !C The energy function is Kihara potential
18767 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18768 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18769 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18770 !C simple Kihara potential
18771       subroutine calctube2(Etube)
18772             real(kind=8),dimension(3) :: vectube
18773       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18774        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18775        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18776       integer:: i,j,iti
18777       Etube=0.0d0
18778       do i=itube_start,itube_end
18779         enetube(i)=0.0d0
18780         enetube(i+nres)=0.0d0
18781       enddo
18782 !C first we calculate the distance from tube center
18783 !C first sugare-phosphate group for NARES this would be peptide group
18784 !C for UNRES
18785        do i=itube_start,itube_end
18786 !C lets ommit dummy atoms for now
18787
18788        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18789 !C now calculate distance from center of tube and direction vectors
18790 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18791 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18792 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18793 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18794       xmin=boxxsize
18795       ymin=boxysize
18796         do j=-1,1
18797          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18798          vectube(1)=vectube(1)+boxxsize*j
18799          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18800          vectube(2)=vectube(2)+boxysize*j
18801
18802          xminact=abs(vectube(1)-tubecenter(1))
18803          yminact=abs(vectube(2)-tubecenter(2))
18804            if (xmin.gt.xminact) then
18805             xmin=xminact
18806             xtemp=vectube(1)
18807            endif
18808            if (ymin.gt.yminact) then
18809              ymin=yminact
18810              ytemp=vectube(2)
18811             endif
18812          enddo
18813       vectube(1)=xtemp
18814       vectube(2)=ytemp
18815       vectube(1)=vectube(1)-tubecenter(1)
18816       vectube(2)=vectube(2)-tubecenter(2)
18817
18818 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18819 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18820
18821 !C as the tube is infinity we do not calculate the Z-vector use of Z
18822 !C as chosen axis
18823       vectube(3)=0.0d0
18824 !C now calculte the distance
18825        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18826 !C now normalize vector
18827       vectube(1)=vectube(1)/tub_r
18828       vectube(2)=vectube(2)/tub_r
18829 !C calculte rdiffrence between r and r0
18830       rdiff=tub_r-tubeR0
18831 !C and its 6 power
18832       rdiff6=rdiff**6.0d0
18833 !C THIS FRAGMENT MAKES TUBE FINITE
18834         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18835         if (positi.le.0) positi=positi+boxzsize
18836 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18837 !c for each residue check if it is in lipid or lipid water border area
18838 !C       respos=mod(c(3,i+nres),boxzsize)
18839 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18840        if ((positi.gt.bordtubebot)  &
18841         .and.(positi.lt.bordtubetop)) then
18842 !C the energy transfer exist
18843         if (positi.lt.buftubebot) then
18844          fracinbuf=1.0d0-  &
18845            ((positi-bordtubebot)/tubebufthick)
18846 !C lipbufthick is thickenes of lipid buffore
18847          sstube=sscalelip(fracinbuf)
18848          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18849 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18850          enetube(i)=enetube(i)+sstube*tubetranenepep
18851 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18852 !C     &+ssgradtube*tubetranene(itype(i,1))
18853 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18854 !C     &+ssgradtube*tubetranene(itype(i,1))
18855 !C         print *,"doing sccale for lower part"
18856         elseif (positi.gt.buftubetop) then
18857          fracinbuf=1.0d0-  &
18858         ((bordtubetop-positi)/tubebufthick)
18859          sstube=sscalelip(fracinbuf)
18860          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18861          enetube(i)=enetube(i)+sstube*tubetranenepep
18862 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18863 !C     &+ssgradtube*tubetranene(itype(i,1))
18864 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18865 !C     &+ssgradtube*tubetranene(itype(i,1))
18866 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18867         else
18868          sstube=1.0d0
18869          ssgradtube=0.0d0
18870          enetube(i)=enetube(i)+sstube*tubetranenepep
18871 !C         print *,"I am in true lipid"
18872         endif
18873         else
18874 !C          sstube=0.0d0
18875 !C          ssgradtube=0.0d0
18876         cycle
18877         endif ! if in lipid or buffor
18878
18879 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18880        enetube(i)=enetube(i)+sstube* &
18881         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18882 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18883 !C       print *,rdiff,rdiff6,pep_aa_tube
18884 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18885 !C now we calculate gradient
18886        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18887              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18888 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18889 !C     &rdiff,fac
18890
18891 !C now direction of gg_tube vector
18892        do j=1,3
18893         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18894         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18895         enddo
18896          gg_tube(3,i)=gg_tube(3,i)  &
18897        +ssgradtube*enetube(i)/sstube/2.0d0
18898          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18899        +ssgradtube*enetube(i)/sstube/2.0d0
18900
18901         enddo
18902 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18903 !C        print *,gg_tube(1,0),"TU"
18904         do i=itube_start,itube_end
18905 !C Lets not jump over memory as we use many times iti
18906          iti=itype(i,1)
18907 !C lets ommit dummy atoms for now
18908          if ((iti.eq.ntyp1) &
18909 !!C in UNRES uncomment the line below as GLY has no side-chain...
18910            .or.(iti.eq.10) &
18911           ) cycle
18912           vectube(1)=c(1,i+nres)
18913           vectube(1)=mod(vectube(1),boxxsize)
18914           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18915           vectube(2)=c(2,i+nres)
18916           vectube(2)=mod(vectube(2),boxysize)
18917           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18918
18919       vectube(1)=vectube(1)-tubecenter(1)
18920       vectube(2)=vectube(2)-tubecenter(2)
18921 !C THIS FRAGMENT MAKES TUBE FINITE
18922         positi=(mod(c(3,i+nres),boxzsize))
18923         if (positi.le.0) positi=positi+boxzsize
18924 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18925 !c for each residue check if it is in lipid or lipid water border area
18926 !C       respos=mod(c(3,i+nres),boxzsize)
18927 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18928
18929        if ((positi.gt.bordtubebot)  &
18930         .and.(positi.lt.bordtubetop)) then
18931 !C the energy transfer exist
18932         if (positi.lt.buftubebot) then
18933          fracinbuf=1.0d0- &
18934             ((positi-bordtubebot)/tubebufthick)
18935 !C lipbufthick is thickenes of lipid buffore
18936          sstube=sscalelip(fracinbuf)
18937          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18938 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18939          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18940 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18941 !C     &+ssgradtube*tubetranene(itype(i,1))
18942 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18943 !C     &+ssgradtube*tubetranene(itype(i,1))
18944 !C         print *,"doing sccale for lower part"
18945         elseif (positi.gt.buftubetop) then
18946          fracinbuf=1.0d0- &
18947         ((bordtubetop-positi)/tubebufthick)
18948
18949          sstube=sscalelip(fracinbuf)
18950          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18951          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18952 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18953 !C     &+ssgradtube*tubetranene(itype(i,1))
18954 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18955 !C     &+ssgradtube*tubetranene(itype(i,1))
18956 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18957         else
18958          sstube=1.0d0
18959          ssgradtube=0.0d0
18960          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18961 !C         print *,"I am in true lipid"
18962         endif
18963         else
18964 !C          sstube=0.0d0
18965 !C          ssgradtube=0.0d0
18966         cycle
18967         endif ! if in lipid or buffor
18968 !CEND OF FINITE FRAGMENT
18969 !C as the tube is infinity we do not calculate the Z-vector use of Z
18970 !C as chosen axis
18971       vectube(3)=0.0d0
18972 !C now calculte the distance
18973        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18974 !C now normalize vector
18975       vectube(1)=vectube(1)/tub_r
18976       vectube(2)=vectube(2)/tub_r
18977 !C calculte rdiffrence between r and r0
18978       rdiff=tub_r-tubeR0
18979 !C and its 6 power
18980       rdiff6=rdiff**6.0d0
18981 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18982        sc_aa_tube=sc_aa_tube_par(iti)
18983        sc_bb_tube=sc_bb_tube_par(iti)
18984        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
18985                        *sstube+enetube(i+nres)
18986 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18987 !C now we calculate gradient
18988        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
18989             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
18990 !C now direction of gg_tube vector
18991          do j=1,3
18992           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18993           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18994          enddo
18995          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
18996        +ssgradtube*enetube(i+nres)/sstube
18997          gg_tube(3,i-1)= gg_tube(3,i-1) &
18998        +ssgradtube*enetube(i+nres)/sstube
18999
19000         enddo
19001         do i=itube_start,itube_end
19002           Etube=Etube+enetube(i)+enetube(i+nres)
19003         enddo
19004 !C        print *,"ETUBE", etube
19005         return
19006         end subroutine calctube2
19007 !=====================================================================================================================================
19008       subroutine calcnano(Etube)
19009       real(kind=8),dimension(3) :: vectube
19010
19011       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19012        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19013        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19014        integer:: i,j,iti,r
19015
19016       Etube=0.0d0
19017 !      print *,itube_start,itube_end,"poczatek"
19018       do i=itube_start,itube_end
19019         enetube(i)=0.0d0
19020         enetube(i+nres)=0.0d0
19021       enddo
19022 !C first we calculate the distance from tube center
19023 !C first sugare-phosphate group for NARES this would be peptide group
19024 !C for UNRES
19025        do i=itube_start,itube_end
19026 !C lets ommit dummy atoms for now
19027        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19028 !C now calculate distance from center of tube and direction vectors
19029       xmin=boxxsize
19030       ymin=boxysize
19031       zmin=boxzsize
19032
19033         do j=-1,1
19034          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19035          vectube(1)=vectube(1)+boxxsize*j
19036          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19037          vectube(2)=vectube(2)+boxysize*j
19038          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19039          vectube(3)=vectube(3)+boxzsize*j
19040
19041
19042          xminact=dabs(vectube(1)-tubecenter(1))
19043          yminact=dabs(vectube(2)-tubecenter(2))
19044          zminact=dabs(vectube(3)-tubecenter(3))
19045
19046            if (xmin.gt.xminact) then
19047             xmin=xminact
19048             xtemp=vectube(1)
19049            endif
19050            if (ymin.gt.yminact) then
19051              ymin=yminact
19052              ytemp=vectube(2)
19053             endif
19054            if (zmin.gt.zminact) then
19055              zmin=zminact
19056              ztemp=vectube(3)
19057             endif
19058          enddo
19059       vectube(1)=xtemp
19060       vectube(2)=ytemp
19061       vectube(3)=ztemp
19062
19063       vectube(1)=vectube(1)-tubecenter(1)
19064       vectube(2)=vectube(2)-tubecenter(2)
19065       vectube(3)=vectube(3)-tubecenter(3)
19066
19067 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19068 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19069 !C as the tube is infinity we do not calculate the Z-vector use of Z
19070 !C as chosen axis
19071 !C      vectube(3)=0.0d0
19072 !C now calculte the distance
19073        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19074 !C now normalize vector
19075       vectube(1)=vectube(1)/tub_r
19076       vectube(2)=vectube(2)/tub_r
19077       vectube(3)=vectube(3)/tub_r
19078 !C calculte rdiffrence between r and r0
19079       rdiff=tub_r-tubeR0
19080 !C and its 6 power
19081       rdiff6=rdiff**6.0d0
19082 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19083        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19084 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19085 !C       print *,rdiff,rdiff6,pep_aa_tube
19086 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19087 !C now we calculate gradient
19088        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19089             6.0d0*pep_bb_tube)/rdiff6/rdiff
19090 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19091 !C     &rdiff,fac
19092          if (acavtubpep.eq.0.0d0) then
19093 !C go to 667
19094          enecavtube(i)=0.0
19095          faccav=0.0
19096          else
19097          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19098          enecavtube(i)=  &
19099         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19100         /denominator
19101          enecavtube(i)=0.0
19102          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19103         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19104         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19105         /denominator**2.0d0
19106 !C         faccav=0.0
19107 !C         fac=fac+faccav
19108 !C 667     continue
19109          endif
19110           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19111         do j=1,3
19112         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19113         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19114         enddo
19115         enddo
19116
19117        do i=itube_start,itube_end
19118         enecavtube(i)=0.0d0
19119 !C Lets not jump over memory as we use many times iti
19120          iti=itype(i,1)
19121 !C lets ommit dummy atoms for now
19122          if ((iti.eq.ntyp1) &
19123 !C in UNRES uncomment the line below as GLY has no side-chain...
19124 !C      .or.(iti.eq.10)
19125          ) cycle
19126       xmin=boxxsize
19127       ymin=boxysize
19128       zmin=boxzsize
19129         do j=-1,1
19130          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19131          vectube(1)=vectube(1)+boxxsize*j
19132          vectube(2)=dmod((c(2,i+nres)),boxysize)
19133          vectube(2)=vectube(2)+boxysize*j
19134          vectube(3)=dmod((c(3,i+nres)),boxzsize)
19135          vectube(3)=vectube(3)+boxzsize*j
19136
19137
19138          xminact=dabs(vectube(1)-tubecenter(1))
19139          yminact=dabs(vectube(2)-tubecenter(2))
19140          zminact=dabs(vectube(3)-tubecenter(3))
19141
19142            if (xmin.gt.xminact) then
19143             xmin=xminact
19144             xtemp=vectube(1)
19145            endif
19146            if (ymin.gt.yminact) then
19147              ymin=yminact
19148              ytemp=vectube(2)
19149             endif
19150            if (zmin.gt.zminact) then
19151              zmin=zminact
19152              ztemp=vectube(3)
19153             endif
19154          enddo
19155       vectube(1)=xtemp
19156       vectube(2)=ytemp
19157       vectube(3)=ztemp
19158
19159 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19160 !C     &     tubecenter(2)
19161       vectube(1)=vectube(1)-tubecenter(1)
19162       vectube(2)=vectube(2)-tubecenter(2)
19163       vectube(3)=vectube(3)-tubecenter(3)
19164 !C now calculte the distance
19165        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19166 !C now normalize vector
19167       vectube(1)=vectube(1)/tub_r
19168       vectube(2)=vectube(2)/tub_r
19169       vectube(3)=vectube(3)/tub_r
19170
19171 !C calculte rdiffrence between r and r0
19172       rdiff=tub_r-tubeR0
19173 !C and its 6 power
19174       rdiff6=rdiff**6.0d0
19175        sc_aa_tube=sc_aa_tube_par(iti)
19176        sc_bb_tube=sc_bb_tube_par(iti)
19177        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19178 !C       enetube(i+nres)=0.0d0
19179 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19180 !C now we calculate gradient
19181        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19182             6.0d0*sc_bb_tube/rdiff6/rdiff
19183 !C       fac=0.0
19184 !C now direction of gg_tube vector
19185 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19186          if (acavtub(iti).eq.0.0d0) then
19187 !C go to 667
19188          enecavtube(i+nres)=0.0d0
19189          faccav=0.0d0
19190          else
19191          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19192          enecavtube(i+nres)=   &
19193         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19194         /denominator
19195 !C         enecavtube(i)=0.0
19196          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19197         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19198         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19199         /denominator**2.0d0
19200 !C         faccav=0.0
19201          fac=fac+faccav
19202 !C 667     continue
19203          endif
19204 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19205 !C     &   enecavtube(i),faccav
19206 !C         print *,"licz=",
19207 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19208 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19209          do j=1,3
19210           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19211           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19212          enddo
19213           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19214         enddo
19215
19216
19217
19218         do i=itube_start,itube_end
19219           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19220          +enecavtube(i+nres)
19221         enddo
19222 !        do i=1,20
19223 !         print *,"begin", i,"a"
19224 !         do r=1,10000
19225 !          rdiff=r/100.0d0
19226 !          rdiff6=rdiff**6.0d0
19227 !          sc_aa_tube=sc_aa_tube_par(i)
19228 !          sc_bb_tube=sc_bb_tube_par(i)
19229 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19230 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19231 !          enecavtube(i)=   &
19232 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19233 !         /denominator
19234
19235 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19236 !         enddo
19237 !         print *,"end",i,"a"
19238 !        enddo
19239 !C        print *,"ETUBE", etube
19240         return
19241         end subroutine calcnano
19242
19243 !===============================================
19244 !--------------------------------------------------------------------------------
19245 !C first for shielding is setting of function of side-chains
19246
19247        subroutine set_shield_fac2
19248        real(kind=8) :: div77_81=0.974996043d0, &
19249         div4_81=0.2222222222d0
19250        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19251          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19252          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19253          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19254 !C the vector between center of side_chain and peptide group
19255        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19256          pept_group,costhet_grad,cosphi_grad_long, &
19257          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19258          sh_frac_dist_grad,pep_side
19259         integer i,j,k
19260 !C      write(2,*) "ivec",ivec_start,ivec_end
19261       do i=1,nres
19262         fac_shield(i)=0.0d0
19263         do j=1,3
19264         grad_shield(j,i)=0.0d0
19265         enddo
19266       enddo
19267       do i=ivec_start,ivec_end
19268 !C      do i=1,nres-1
19269 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19270       ishield_list(i)=0
19271       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19272 !Cif there two consequtive dummy atoms there is no peptide group between them
19273 !C the line below has to be changed for FGPROC>1
19274       VolumeTotal=0.0
19275       do k=1,nres
19276        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19277        dist_pep_side=0.0
19278        dist_side_calf=0.0
19279        do j=1,3
19280 !C first lets set vector conecting the ithe side-chain with kth side-chain
19281       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19282 !C      pep_side(j)=2.0d0
19283 !C and vector conecting the side-chain with its proper calfa
19284       side_calf(j)=c(j,k+nres)-c(j,k)
19285 !C      side_calf(j)=2.0d0
19286       pept_group(j)=c(j,i)-c(j,i+1)
19287 !C lets have their lenght
19288       dist_pep_side=pep_side(j)**2+dist_pep_side
19289       dist_side_calf=dist_side_calf+side_calf(j)**2
19290       dist_pept_group=dist_pept_group+pept_group(j)**2
19291       enddo
19292        dist_pep_side=sqrt(dist_pep_side)
19293        dist_pept_group=sqrt(dist_pept_group)
19294        dist_side_calf=sqrt(dist_side_calf)
19295       do j=1,3
19296         pep_side_norm(j)=pep_side(j)/dist_pep_side
19297         side_calf_norm(j)=dist_side_calf
19298       enddo
19299 !C now sscale fraction
19300        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19301 !C       print *,buff_shield,"buff"
19302 !C now sscale
19303         if (sh_frac_dist.le.0.0) cycle
19304 !C        print *,ishield_list(i),i
19305 !C If we reach here it means that this side chain reaches the shielding sphere
19306 !C Lets add him to the list for gradient
19307         ishield_list(i)=ishield_list(i)+1
19308 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19309 !C this list is essential otherwise problem would be O3
19310         shield_list(ishield_list(i),i)=k
19311 !C Lets have the sscale value
19312         if (sh_frac_dist.gt.1.0) then
19313          scale_fac_dist=1.0d0
19314          do j=1,3
19315          sh_frac_dist_grad(j)=0.0d0
19316          enddo
19317         else
19318          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19319                         *(2.0d0*sh_frac_dist-3.0d0)
19320          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19321                        /dist_pep_side/buff_shield*0.5d0
19322          do j=1,3
19323          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19324 !C         sh_frac_dist_grad(j)=0.0d0
19325 !C         scale_fac_dist=1.0d0
19326 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19327 !C     &                    sh_frac_dist_grad(j)
19328          enddo
19329         endif
19330 !C this is what is now we have the distance scaling now volume...
19331       short=short_r_sidechain(itype(k,1))
19332       long=long_r_sidechain(itype(k,1))
19333       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19334       sinthet=short/dist_pep_side*costhet
19335 !C now costhet_grad
19336 !C       costhet=0.6d0
19337 !C       sinthet=0.8
19338        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19339 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19340 !C     &             -short/dist_pep_side**2/costhet)
19341 !C       costhet_fac=0.0d0
19342        do j=1,3
19343          costhet_grad(j)=costhet_fac*pep_side(j)
19344        enddo
19345 !C remember for the final gradient multiply costhet_grad(j)
19346 !C for side_chain by factor -2 !
19347 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19348 !C pep_side0pept_group is vector multiplication
19349       pep_side0pept_group=0.0d0
19350       do j=1,3
19351       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19352       enddo
19353       cosalfa=(pep_side0pept_group/ &
19354       (dist_pep_side*dist_side_calf))
19355       fac_alfa_sin=1.0d0-cosalfa**2
19356       fac_alfa_sin=dsqrt(fac_alfa_sin)
19357       rkprim=fac_alfa_sin*(long-short)+short
19358 !C      rkprim=short
19359
19360 !C now costhet_grad
19361        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19362 !C       cosphi=0.6
19363        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19364        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19365            dist_pep_side**2)
19366 !C       sinphi=0.8
19367        do j=1,3
19368          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19369       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19370       *(long-short)/fac_alfa_sin*cosalfa/ &
19371       ((dist_pep_side*dist_side_calf))* &
19372       ((side_calf(j))-cosalfa* &
19373       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19374 !C       cosphi_grad_long(j)=0.0d0
19375         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19376       *(long-short)/fac_alfa_sin*cosalfa &
19377       /((dist_pep_side*dist_side_calf))* &
19378       (pep_side(j)- &
19379       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19380 !C       cosphi_grad_loc(j)=0.0d0
19381        enddo
19382 !C      print *,sinphi,sinthet
19383       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19384      &                    /VSolvSphere_div
19385 !C     &                    *wshield
19386 !C now the gradient...
19387       do j=1,3
19388       grad_shield(j,i)=grad_shield(j,i) &
19389 !C gradient po skalowaniu
19390                      +(sh_frac_dist_grad(j)*VofOverlap &
19391 !C  gradient po costhet
19392             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19393         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19394             sinphi/sinthet*costhet*costhet_grad(j) &
19395            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19396         )*wshield
19397 !C grad_shield_side is Cbeta sidechain gradient
19398       grad_shield_side(j,ishield_list(i),i)=&
19399              (sh_frac_dist_grad(j)*-2.0d0&
19400              *VofOverlap&
19401             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19402        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19403             sinphi/sinthet*costhet*costhet_grad(j)&
19404            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19405             )*wshield
19406
19407        grad_shield_loc(j,ishield_list(i),i)=   &
19408             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19409       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19410             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19411              ))&
19412              *wshield
19413       enddo
19414       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19415       enddo
19416       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19417
19418 !C      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19419       enddo
19420       return
19421       end subroutine set_shield_fac2
19422 !----------------------------------------------------------------------------
19423 ! SOUBROUTINE FOR AFM
19424        subroutine AFMvel(Eafmforce)
19425        use MD_data, only:totTafm
19426       real(kind=8),dimension(3) :: diffafm
19427       real(kind=8) :: afmdist,Eafmforce
19428        integer :: i
19429 !C Only for check grad COMMENT if not used for checkgrad
19430 !C      totT=3.0d0
19431 !C--------------------------------------------------------
19432 !C      print *,"wchodze"
19433       afmdist=0.0d0
19434       Eafmforce=0.0d0
19435       do i=1,3
19436       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19437       afmdist=afmdist+diffafm(i)**2
19438       enddo
19439       afmdist=dsqrt(afmdist)
19440 !      totTafm=3.0
19441       Eafmforce=0.5d0*forceAFMconst &
19442       *(distafminit+totTafm*velAFMconst-afmdist)**2
19443 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19444       do i=1,3
19445       gradafm(i,afmend-1)=-forceAFMconst* &
19446        (distafminit+totTafm*velAFMconst-afmdist) &
19447        *diffafm(i)/afmdist
19448       gradafm(i,afmbeg-1)=forceAFMconst* &
19449       (distafminit+totTafm*velAFMconst-afmdist) &
19450       *diffafm(i)/afmdist
19451       enddo
19452 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19453       return
19454       end subroutine AFMvel
19455 !---------------------------------------------------------
19456        subroutine AFMforce(Eafmforce)
19457
19458       real(kind=8),dimension(3) :: diffafm
19459 !      real(kind=8) ::afmdist
19460       real(kind=8) :: afmdist,Eafmforce
19461       integer :: i
19462       afmdist=0.0d0
19463       Eafmforce=0.0d0
19464       do i=1,3
19465       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19466       afmdist=afmdist+diffafm(i)**2
19467       enddo
19468       afmdist=dsqrt(afmdist)
19469 !      print *,afmdist,distafminit
19470       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19471       do i=1,3
19472       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19473       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19474       enddo
19475 !C      print *,'AFM',Eafmforce
19476       return
19477       end subroutine AFMforce
19478
19479 !-----------------------------------------------------------------------------
19480 #ifdef WHAM
19481       subroutine read_ssHist
19482 !      implicit none
19483 !      Includes
19484 !      include 'DIMENSIONS'
19485 !      include "DIMENSIONS.FREE"
19486 !      include 'COMMON.FREE'
19487 !     Local variables
19488       integer :: i,j
19489       character(len=80) :: controlcard
19490
19491       do i=1,dyn_nssHist
19492         call card_concat(controlcard,.true.)
19493         read(controlcard,*) &
19494              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19495       enddo
19496
19497       return
19498       end subroutine read_ssHist
19499 #endif
19500 !-----------------------------------------------------------------------------
19501       integer function indmat(i,j)
19502 !el
19503 ! get the position of the jth ijth fragment of the chain coordinate system
19504 ! in the fromto array.
19505         integer :: i,j
19506
19507         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19508       return
19509       end function indmat
19510 !-----------------------------------------------------------------------------
19511       real(kind=8) function sigm(x)
19512 !el
19513        real(kind=8) :: x
19514         sigm=0.25d0*x
19515       return
19516       end function sigm
19517 !-----------------------------------------------------------------------------
19518 !-----------------------------------------------------------------------------
19519       subroutine alloc_ener_arrays
19520 !EL Allocation of arrays used by module energy
19521       use MD_data, only: mset
19522 !el local variables
19523       integer :: i,j
19524
19525       if(nres.lt.100) then
19526         maxconts=nres
19527       elseif(nres.lt.200) then
19528         maxconts=0.8*nres      ! Max. number of contacts per residue
19529       else
19530         maxconts=0.6*nres ! (maxconts=maxres/4)
19531       endif
19532       maxcont=12*nres      ! Max. number of SC contacts
19533       maxvar=6*nres      ! Max. number of variables
19534 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19535       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19536 !----------------------
19537 ! arrays in subroutine init_int_table
19538 !el#ifdef MPI
19539 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19540 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19541 !el#endif
19542       allocate(nint_gr(nres))
19543       allocate(nscp_gr(nres))
19544       allocate(ielstart(nres))
19545       allocate(ielend(nres))
19546 !(maxres)
19547       allocate(istart(nres,maxint_gr))
19548       allocate(iend(nres,maxint_gr))
19549 !(maxres,maxint_gr)
19550       allocate(iscpstart(nres,maxint_gr))
19551       allocate(iscpend(nres,maxint_gr))
19552 !(maxres,maxint_gr)
19553       allocate(ielstart_vdw(nres))
19554       allocate(ielend_vdw(nres))
19555 !(maxres)
19556       allocate(nint_gr_nucl(nres))
19557       allocate(nscp_gr_nucl(nres))
19558       allocate(ielstart_nucl(nres))
19559       allocate(ielend_nucl(nres))
19560 !(maxres)
19561       allocate(istart_nucl(nres,maxint_gr))
19562       allocate(iend_nucl(nres,maxint_gr))
19563 !(maxres,maxint_gr)
19564       allocate(iscpstart_nucl(nres,maxint_gr))
19565       allocate(iscpend_nucl(nres,maxint_gr))
19566 !(maxres,maxint_gr)
19567       allocate(ielstart_vdw_nucl(nres))
19568       allocate(ielend_vdw_nucl(nres))
19569
19570       allocate(lentyp(0:nfgtasks-1))
19571 !(0:maxprocs-1)
19572 !----------------------
19573 ! commom.contacts
19574 !      common /contacts/
19575       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19576       allocate(icont(2,maxcont))
19577 !(2,maxcont)
19578 !      common /contacts1/
19579       allocate(num_cont(0:nres+4))
19580 !(maxres)
19581       allocate(jcont(maxconts,nres))
19582 !(maxconts,maxres)
19583       allocate(facont(maxconts,nres))
19584 !(maxconts,maxres)
19585       allocate(gacont(3,maxconts,nres))
19586 !(3,maxconts,maxres)
19587 !      common /contacts_hb/
19588       allocate(gacontp_hb1(3,maxconts,nres))
19589       allocate(gacontp_hb2(3,maxconts,nres))
19590       allocate(gacontp_hb3(3,maxconts,nres))
19591       allocate(gacontm_hb1(3,maxconts,nres))
19592       allocate(gacontm_hb2(3,maxconts,nres))
19593       allocate(gacontm_hb3(3,maxconts,nres))
19594       allocate(gacont_hbr(3,maxconts,nres))
19595       allocate(grij_hb_cont(3,maxconts,nres))
19596 !(3,maxconts,maxres)
19597       allocate(facont_hb(maxconts,nres))
19598
19599       allocate(ees0p(maxconts,nres))
19600       allocate(ees0m(maxconts,nres))
19601       allocate(d_cont(maxconts,nres))
19602       allocate(ees0plist(maxconts,nres))
19603
19604 !(maxconts,maxres)
19605       allocate(num_cont_hb(nres))
19606 !(maxres)
19607       allocate(jcont_hb(maxconts,nres))
19608 !(maxconts,maxres)
19609 !      common /rotat/
19610       allocate(Ug(2,2,nres))
19611       allocate(Ugder(2,2,nres))
19612       allocate(Ug2(2,2,nres))
19613       allocate(Ug2der(2,2,nres))
19614 !(2,2,maxres)
19615       allocate(obrot(2,nres))
19616       allocate(obrot2(2,nres))
19617       allocate(obrot_der(2,nres))
19618       allocate(obrot2_der(2,nres))
19619 !(2,maxres)
19620 !      common /precomp1/
19621       allocate(mu(2,nres))
19622       allocate(muder(2,nres))
19623       allocate(Ub2(2,nres))
19624       Ub2(1,:)=0.0d0
19625       Ub2(2,:)=0.0d0
19626       allocate(Ub2der(2,nres))
19627       allocate(Ctobr(2,nres))
19628       allocate(Ctobrder(2,nres))
19629       allocate(Dtobr2(2,nres))
19630       allocate(Dtobr2der(2,nres))
19631 !(2,maxres)
19632       allocate(EUg(2,2,nres))
19633       allocate(EUgder(2,2,nres))
19634       allocate(CUg(2,2,nres))
19635       allocate(CUgder(2,2,nres))
19636       allocate(DUg(2,2,nres))
19637       allocate(Dugder(2,2,nres))
19638       allocate(DtUg2(2,2,nres))
19639       allocate(DtUg2der(2,2,nres))
19640 !(2,2,maxres)
19641 !      common /precomp2/
19642       allocate(Ug2Db1t(2,nres))
19643       allocate(Ug2Db1tder(2,nres))
19644       allocate(CUgb2(2,nres))
19645       allocate(CUgb2der(2,nres))
19646 !(2,maxres)
19647       allocate(EUgC(2,2,nres))
19648       allocate(EUgCder(2,2,nres))
19649       allocate(EUgD(2,2,nres))
19650       allocate(EUgDder(2,2,nres))
19651       allocate(DtUg2EUg(2,2,nres))
19652       allocate(Ug2DtEUg(2,2,nres))
19653 !(2,2,maxres)
19654       allocate(Ug2DtEUgder(2,2,2,nres))
19655       allocate(DtUg2EUgder(2,2,2,nres))
19656 !(2,2,2,maxres)
19657 !      common /rotat_old/
19658       allocate(costab(nres))
19659       allocate(sintab(nres))
19660       allocate(costab2(nres))
19661       allocate(sintab2(nres))
19662 !(maxres)
19663 !      common /dipmat/
19664       allocate(a_chuj(2,2,maxconts,nres))
19665 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19666       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19667 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19668 !      common /contdistrib/
19669       allocate(ncont_sent(nres))
19670       allocate(ncont_recv(nres))
19671
19672       allocate(iat_sent(nres))
19673 !(maxres)
19674       allocate(iint_sent(4,nres,nres))
19675       allocate(iint_sent_local(4,nres,nres))
19676 !(4,maxres,maxres)
19677       allocate(iturn3_sent(4,0:nres+4))
19678       allocate(iturn4_sent(4,0:nres+4))
19679       allocate(iturn3_sent_local(4,nres))
19680       allocate(iturn4_sent_local(4,nres))
19681 !(4,maxres)
19682       allocate(itask_cont_from(0:nfgtasks-1))
19683       allocate(itask_cont_to(0:nfgtasks-1))
19684 !(0:max_fg_procs-1)
19685
19686
19687
19688 !----------------------
19689 ! commom.deriv;
19690 !      common /derivat/
19691       allocate(dcdv(6,maxdim))
19692       allocate(dxdv(6,maxdim))
19693 !(6,maxdim)
19694       allocate(dxds(6,nres))
19695 !(6,maxres)
19696       allocate(gradx(3,-1:nres,0:2))
19697       allocate(gradc(3,-1:nres,0:2))
19698 !(3,maxres,2)
19699       allocate(gvdwx(3,-1:nres))
19700       allocate(gvdwc(3,-1:nres))
19701       allocate(gelc(3,-1:nres))
19702       allocate(gelc_long(3,-1:nres))
19703       allocate(gvdwpp(3,-1:nres))
19704       allocate(gvdwc_scpp(3,-1:nres))
19705       allocate(gradx_scp(3,-1:nres))
19706       allocate(gvdwc_scp(3,-1:nres))
19707       allocate(ghpbx(3,-1:nres))
19708       allocate(ghpbc(3,-1:nres))
19709       allocate(gradcorr(3,-1:nres))
19710       allocate(gradcorr_long(3,-1:nres))
19711       allocate(gradcorr5_long(3,-1:nres))
19712       allocate(gradcorr6_long(3,-1:nres))
19713       allocate(gcorr6_turn_long(3,-1:nres))
19714       allocate(gradxorr(3,-1:nres))
19715       allocate(gradcorr5(3,-1:nres))
19716       allocate(gradcorr6(3,-1:nres))
19717       allocate(gliptran(3,-1:nres))
19718       allocate(gliptranc(3,-1:nres))
19719       allocate(gliptranx(3,-1:nres))
19720       allocate(gshieldx(3,-1:nres))
19721       allocate(gshieldc(3,-1:nres))
19722       allocate(gshieldc_loc(3,-1:nres))
19723       allocate(gshieldx_ec(3,-1:nres))
19724       allocate(gshieldc_ec(3,-1:nres))
19725       allocate(gshieldc_loc_ec(3,-1:nres))
19726       allocate(gshieldx_t3(3,-1:nres))
19727       allocate(gshieldc_t3(3,-1:nres))
19728       allocate(gshieldc_loc_t3(3,-1:nres))
19729       allocate(gshieldx_t4(3,-1:nres))
19730       allocate(gshieldc_t4(3,-1:nres))
19731       allocate(gshieldc_loc_t4(3,-1:nres))
19732       allocate(gshieldx_ll(3,-1:nres))
19733       allocate(gshieldc_ll(3,-1:nres))
19734       allocate(gshieldc_loc_ll(3,-1:nres))
19735       allocate(grad_shield(3,-1:nres))
19736       allocate(gg_tube_sc(3,-1:nres))
19737       allocate(gg_tube(3,-1:nres))
19738       allocate(gradafm(3,-1:nres))
19739       allocate(gradb_nucl(3,-1:nres))
19740       allocate(gradbx_nucl(3,-1:nres))
19741       allocate(gvdwpsb1(3,-1:nres))
19742       allocate(gelpp(3,-1:nres))
19743       allocate(gvdwpsb(3,-1:nres))
19744       allocate(gelsbc(3,-1:nres))
19745       allocate(gelsbx(3,-1:nres))
19746       allocate(gvdwsbx(3,-1:nres))
19747       allocate(gvdwsbc(3,-1:nres))
19748       allocate(gsbloc(3,-1:nres))
19749       allocate(gsblocx(3,-1:nres))
19750       allocate(gradcorr_nucl(3,-1:nres))
19751       allocate(gradxorr_nucl(3,-1:nres))
19752       allocate(gradcorr3_nucl(3,-1:nres))
19753       allocate(gradxorr3_nucl(3,-1:nres))
19754       allocate(gvdwpp_nucl(3,-1:nres))
19755       allocate(gradpepcat(3,-1:nres))
19756       allocate(gradpepcatx(3,-1:nres))
19757       allocate(gradcatcat(3,-1:nres))
19758 !(3,maxres)
19759       allocate(grad_shield_side(3,50,nres))
19760       allocate(grad_shield_loc(3,50,nres))
19761 ! grad for shielding surroing
19762       allocate(gloc(0:maxvar,0:2))
19763       allocate(gloc_x(0:maxvar,2))
19764 !(maxvar,2)
19765       allocate(gel_loc(3,-1:nres))
19766       allocate(gel_loc_long(3,-1:nres))
19767       allocate(gcorr3_turn(3,-1:nres))
19768       allocate(gcorr4_turn(3,-1:nres))
19769       allocate(gcorr6_turn(3,-1:nres))
19770       allocate(gradb(3,-1:nres))
19771       allocate(gradbx(3,-1:nres))
19772 !(3,maxres)
19773       allocate(gel_loc_loc(maxvar))
19774       allocate(gel_loc_turn3(maxvar))
19775       allocate(gel_loc_turn4(maxvar))
19776       allocate(gel_loc_turn6(maxvar))
19777       allocate(gcorr_loc(maxvar))
19778       allocate(g_corr5_loc(maxvar))
19779       allocate(g_corr6_loc(maxvar))
19780 !(maxvar)
19781       allocate(gsccorc(3,-1:nres))
19782       allocate(gsccorx(3,-1:nres))
19783 !(3,maxres)
19784       allocate(gsccor_loc(-1:nres))
19785 !(maxres)
19786       allocate(dtheta(3,2,-1:nres))
19787 !(3,2,maxres)
19788       allocate(gscloc(3,-1:nres))
19789       allocate(gsclocx(3,-1:nres))
19790 !(3,maxres)
19791       allocate(dphi(3,3,-1:nres))
19792       allocate(dalpha(3,3,-1:nres))
19793       allocate(domega(3,3,-1:nres))
19794 !(3,3,maxres)
19795 !      common /deriv_scloc/
19796       allocate(dXX_C1tab(3,nres))
19797       allocate(dYY_C1tab(3,nres))
19798       allocate(dZZ_C1tab(3,nres))
19799       allocate(dXX_Ctab(3,nres))
19800       allocate(dYY_Ctab(3,nres))
19801       allocate(dZZ_Ctab(3,nres))
19802       allocate(dXX_XYZtab(3,nres))
19803       allocate(dYY_XYZtab(3,nres))
19804       allocate(dZZ_XYZtab(3,nres))
19805 !(3,maxres)
19806 !      common /mpgrad/
19807       allocate(jgrad_start(nres))
19808       allocate(jgrad_end(nres))
19809 !(maxres)
19810 !----------------------
19811
19812 !      common /indices/
19813       allocate(ibond_displ(0:nfgtasks-1))
19814       allocate(ibond_count(0:nfgtasks-1))
19815       allocate(ithet_displ(0:nfgtasks-1))
19816       allocate(ithet_count(0:nfgtasks-1))
19817       allocate(iphi_displ(0:nfgtasks-1))
19818       allocate(iphi_count(0:nfgtasks-1))
19819       allocate(iphi1_displ(0:nfgtasks-1))
19820       allocate(iphi1_count(0:nfgtasks-1))
19821       allocate(ivec_displ(0:nfgtasks-1))
19822       allocate(ivec_count(0:nfgtasks-1))
19823       allocate(iset_displ(0:nfgtasks-1))
19824       allocate(iset_count(0:nfgtasks-1))
19825       allocate(iint_count(0:nfgtasks-1))
19826       allocate(iint_displ(0:nfgtasks-1))
19827 !(0:max_fg_procs-1)
19828 !----------------------
19829 ! common.MD
19830 !      common /mdgrad/
19831       allocate(gcart(3,-1:nres))
19832       allocate(gxcart(3,-1:nres))
19833 !(3,0:MAXRES)
19834       allocate(gradcag(3,-1:nres))
19835       allocate(gradxag(3,-1:nres))
19836 !(3,MAXRES)
19837 !      common /back_constr/
19838 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19839       allocate(dutheta(nres))
19840       allocate(dugamma(nres))
19841 !(maxres)
19842       allocate(duscdiff(3,nres))
19843       allocate(duscdiffx(3,nres))
19844 !(3,maxres)
19845 !el i io:read_fragments
19846 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19847 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19848 !      common /qmeas/
19849 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19850 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19851       allocate(mset(0:nprocs))  !(maxprocs/20)
19852       mset(:)=0
19853 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19854 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19855       allocate(dUdconst(3,0:nres))
19856       allocate(dUdxconst(3,0:nres))
19857       allocate(dqwol(3,0:nres))
19858       allocate(dxqwol(3,0:nres))
19859 !(3,0:MAXRES)
19860 !----------------------
19861 ! common.sbridge
19862 !      common /sbridge/ in io_common: read_bridge
19863 !el    allocate((:),allocatable :: iss      !(maxss)
19864 !      common /links/  in io_common: read_bridge
19865 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19866 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19867 !      common /dyn_ssbond/
19868 ! and side-chain vectors in theta or phi.
19869       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19870 !(maxres,maxres)
19871 !      do i=1,nres
19872 !        do j=i+1,nres
19873       dyn_ssbond_ij(:,:)=1.0d300
19874 !        enddo
19875 !      enddo
19876
19877 !      if (nss.gt.0) then
19878         allocate(idssb(maxdim),jdssb(maxdim))
19879 !        allocate(newihpb(nss),newjhpb(nss))
19880 !(maxdim)
19881 !      endif
19882       allocate(ishield_list(nres))
19883       allocate(shield_list(50,nres))
19884       allocate(dyn_ss_mask(nres))
19885       allocate(fac_shield(nres))
19886       allocate(enetube(nres*2))
19887       allocate(enecavtube(nres*2))
19888
19889 !(maxres)
19890       dyn_ss_mask(:)=.false.
19891 !----------------------
19892 ! common.sccor
19893 ! Parameters of the SCCOR term
19894 !      common/sccor/
19895 !el in io_conf: parmread
19896 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
19897 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
19898 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
19899 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
19900 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
19901 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
19902 !      allocate(vlor1sccor(maxterm_sccor,20,20))
19903 !      allocate(vlor2sccor(maxterm_sccor,20,20))
19904 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
19905 !----------------
19906       allocate(gloc_sc(3,0:2*nres,0:10))
19907 !(3,0:maxres2,10)maxres2=2*maxres
19908       allocate(dcostau(3,3,3,2*nres))
19909       allocate(dsintau(3,3,3,2*nres))
19910       allocate(dtauangle(3,3,3,2*nres))
19911       allocate(dcosomicron(3,3,3,2*nres))
19912       allocate(domicron(3,3,3,2*nres))
19913 !(3,3,3,maxres2)maxres2=2*maxres
19914 !----------------------
19915 ! common.var
19916 !      common /restr/
19917       allocate(varall(maxvar))
19918 !(maxvar)(maxvar=6*maxres)
19919       allocate(mask_theta(nres))
19920       allocate(mask_phi(nres))
19921       allocate(mask_side(nres))
19922 !(maxres)
19923 !----------------------
19924 ! common.vectors
19925 !      common /vectors/
19926       allocate(uy(3,nres))
19927       allocate(uz(3,nres))
19928 !(3,maxres)
19929       allocate(uygrad(3,3,2,nres))
19930       allocate(uzgrad(3,3,2,nres))
19931 !(3,3,2,maxres)
19932
19933       return
19934       end subroutine alloc_ener_arrays
19935 !-----------------------------------------------------------------
19936       subroutine ebond_nucl(estr_nucl)
19937 !c
19938 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
19939 !c
19940
19941       real(kind=8),dimension(3) :: u,ud
19942       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
19943       real(kind=8) :: estr_nucl,diff
19944       integer :: iti,i,j,k,nbi
19945       estr_nucl=0.0d0
19946 !C      print *,"I enter ebond"
19947       if (energy_dec) &
19948       write (iout,*) "ibondp_start,ibondp_end",&
19949        ibondp_nucl_start,ibondp_nucl_end
19950       do i=ibondp_nucl_start,ibondp_nucl_end
19951         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
19952          itype(i,2).eq.ntyp1_molec(2)) cycle
19953 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
19954 !          do j=1,3
19955 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
19956 !     &      *dc(j,i-1)/vbld(i)
19957 !          enddo
19958 !          if (energy_dec) write(iout,*)
19959 !     &       "estr1",i,vbld(i),distchainmax,
19960 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
19961
19962           diff = vbld(i)-vbldp0_nucl
19963           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
19964           vbldp0_nucl,diff,AKP_nucl*diff*diff
19965           estr_nucl=estr_nucl+diff*diff
19966 !          print *,estr_nucl
19967           do j=1,3
19968             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
19969           enddo
19970 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
19971       enddo
19972       estr_nucl=0.5d0*AKP_nucl*estr_nucl
19973 !      print *,"partial sum", estr_nucl,AKP_nucl
19974
19975       if (energy_dec) &
19976       write (iout,*) "ibondp_start,ibondp_end",&
19977        ibond_nucl_start,ibond_nucl_end
19978
19979       do i=ibond_nucl_start,ibond_nucl_end
19980 !C        print *, "I am stuck",i
19981         iti=itype(i,2)
19982         if (iti.eq.ntyp1_molec(2)) cycle
19983           nbi=nbondterm_nucl(iti)
19984 !C        print *,iti,nbi
19985           if (nbi.eq.1) then
19986             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
19987
19988             if (energy_dec) &
19989            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
19990            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
19991             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
19992 !            print *,estr_nucl
19993             do j=1,3
19994               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
19995             enddo
19996           else
19997             do j=1,nbi
19998               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
19999               ud(j)=aksc_nucl(j,iti)*diff
20000               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20001             enddo
20002             uprod=u(1)
20003             do j=2,nbi
20004               uprod=uprod*u(j)
20005             enddo
20006             usum=0.0d0
20007             usumsqder=0.0d0
20008             do j=1,nbi
20009               uprod1=1.0d0
20010               uprod2=1.0d0
20011               do k=1,nbi
20012                 if (k.ne.j) then
20013                   uprod1=uprod1*u(k)
20014                   uprod2=uprod2*u(k)*u(k)
20015                 endif
20016               enddo
20017               usum=usum+uprod1
20018               usumsqder=usumsqder+ud(j)*uprod2
20019             enddo
20020             estr_nucl=estr_nucl+uprod/usum
20021             do j=1,3
20022              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20023             enddo
20024         endif
20025       enddo
20026 !C      print *,"I am about to leave ebond"
20027       return
20028       end subroutine ebond_nucl
20029
20030 !-----------------------------------------------------------------------------
20031       subroutine ebend_nucl(etheta_nucl)
20032       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20033       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20034       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20035       logical :: lprn=.false., lprn1=.false.
20036 !el local variables
20037       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20038       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20039       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20040 ! local variables for constrains
20041       real(kind=8) :: difi,thetiii
20042        integer itheta
20043       etheta_nucl=0.0D0
20044 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20045       do i=ithet_nucl_start,ithet_nucl_end
20046         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20047         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20048         (itype(i,2).eq.ntyp1_molec(2))) cycle
20049         dethetai=0.0d0
20050         dephii=0.0d0
20051         dephii1=0.0d0
20052         theti2=0.5d0*theta(i)
20053         ityp2=ithetyp_nucl(itype(i-1,2))
20054         do k=1,nntheterm_nucl
20055           coskt(k)=dcos(k*theti2)
20056           sinkt(k)=dsin(k*theti2)
20057         enddo
20058         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20059 #ifdef OSF
20060           phii=phi(i)
20061           if (phii.ne.phii) phii=150.0
20062 #else
20063           phii=phi(i)
20064 #endif
20065           ityp1=ithetyp_nucl(itype(i-2,2))
20066           do k=1,nsingle_nucl
20067             cosph1(k)=dcos(k*phii)
20068             sinph1(k)=dsin(k*phii)
20069           enddo
20070         else
20071           phii=0.0d0
20072           ityp1=nthetyp_nucl+1
20073           do k=1,nsingle_nucl
20074             cosph1(k)=0.0d0
20075             sinph1(k)=0.0d0
20076           enddo
20077         endif
20078
20079         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20080 #ifdef OSF
20081           phii1=phi(i+1)
20082           if (phii1.ne.phii1) phii1=150.0
20083           phii1=pinorm(phii1)
20084 #else
20085           phii1=phi(i+1)
20086 #endif
20087           ityp3=ithetyp_nucl(itype(i,2))
20088           do k=1,nsingle_nucl
20089             cosph2(k)=dcos(k*phii1)
20090             sinph2(k)=dsin(k*phii1)
20091           enddo
20092         else
20093           phii1=0.0d0
20094           ityp3=nthetyp_nucl+1
20095           do k=1,nsingle_nucl
20096             cosph2(k)=0.0d0
20097             sinph2(k)=0.0d0
20098           enddo
20099         endif
20100         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20101         do k=1,ndouble_nucl
20102           do l=1,k-1
20103             ccl=cosph1(l)*cosph2(k-l)
20104             ssl=sinph1(l)*sinph2(k-l)
20105             scl=sinph1(l)*cosph2(k-l)
20106             csl=cosph1(l)*sinph2(k-l)
20107             cosph1ph2(l,k)=ccl-ssl
20108             cosph1ph2(k,l)=ccl+ssl
20109             sinph1ph2(l,k)=scl+csl
20110             sinph1ph2(k,l)=scl-csl
20111           enddo
20112         enddo
20113         if (lprn) then
20114         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20115          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20116         write (iout,*) "coskt and sinkt",nntheterm_nucl
20117         do k=1,nntheterm_nucl
20118           write (iout,*) k,coskt(k),sinkt(k)
20119         enddo
20120         endif
20121         do k=1,ntheterm_nucl
20122           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20123           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20124            *coskt(k)
20125           if (lprn)&
20126          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20127           " ethetai",ethetai
20128         enddo
20129         if (lprn) then
20130         write (iout,*) "cosph and sinph"
20131         do k=1,nsingle_nucl
20132           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20133         enddo
20134         write (iout,*) "cosph1ph2 and sinph2ph2"
20135         do k=2,ndouble_nucl
20136           do l=1,k-1
20137             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20138               sinph1ph2(l,k),sinph1ph2(k,l)
20139           enddo
20140         enddo
20141         write(iout,*) "ethetai",ethetai
20142         endif
20143         do m=1,ntheterm2_nucl
20144           do k=1,nsingle_nucl
20145             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20146               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20147               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20148               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20149             ethetai=ethetai+sinkt(m)*aux
20150             dethetai=dethetai+0.5d0*m*aux*coskt(m)
20151             dephii=dephii+k*sinkt(m)*(&
20152                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20153                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20154             dephii1=dephii1+k*sinkt(m)*(&
20155                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20156                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20157             if (lprn) &
20158            write (iout,*) "m",m," k",k," bbthet",&
20159               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20160               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20161               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20162               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20163           enddo
20164         enddo
20165         if (lprn) &
20166         write(iout,*) "ethetai",ethetai
20167         do m=1,ntheterm3_nucl
20168           do k=2,ndouble_nucl
20169             do l=1,k-1
20170               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20171                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20172                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20173                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20174               ethetai=ethetai+sinkt(m)*aux
20175               dethetai=dethetai+0.5d0*m*coskt(m)*aux
20176               dephii=dephii+l*sinkt(m)*(&
20177                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20178                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20179                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20180                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20181               dephii1=dephii1+(k-l)*sinkt(m)*( &
20182                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20183                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20184                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20185                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20186               if (lprn) then
20187               write (iout,*) "m",m," k",k," l",l," ffthet", &
20188                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20189                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20190                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20191                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20192               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20193                  cosph1ph2(k,l)*sinkt(m),&
20194                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20195               endif
20196             enddo
20197           enddo
20198         enddo
20199 10      continue
20200         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20201         i,theta(i)*rad2deg,phii*rad2deg, &
20202         phii1*rad2deg,ethetai
20203         etheta_nucl=etheta_nucl+ethetai
20204 !        print *,i,"partial sum",etheta_nucl
20205         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20206         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20207         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20208       enddo
20209       return
20210       end subroutine ebend_nucl
20211 !----------------------------------------------------
20212       subroutine etor_nucl(etors_nucl)
20213 !      implicit real*8 (a-h,o-z)
20214 !      include 'DIMENSIONS'
20215 !      include 'COMMON.VAR'
20216 !      include 'COMMON.GEO'
20217 !      include 'COMMON.LOCAL'
20218 !      include 'COMMON.TORSION'
20219 !      include 'COMMON.INTERACT'
20220 !      include 'COMMON.DERIV'
20221 !      include 'COMMON.CHAIN'
20222 !      include 'COMMON.NAMES'
20223 !      include 'COMMON.IOUNITS'
20224 !      include 'COMMON.FFIELD'
20225 !      include 'COMMON.TORCNSTR'
20226 !      include 'COMMON.CONTROL'
20227       real(kind=8) :: etors_nucl,edihcnstr
20228       logical :: lprn
20229 !el local variables
20230       integer :: i,j,iblock,itori,itori1
20231       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20232                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20233 ! Set lprn=.true. for debugging
20234       lprn=.false.
20235 !     lprn=.true.
20236       etors_nucl=0.0D0
20237 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20238       do i=iphi_nucl_start,iphi_nucl_end
20239         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20240              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20241              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20242         etors_ii=0.0D0
20243         itori=itortyp_nucl(itype(i-2,2))
20244         itori1=itortyp_nucl(itype(i-1,2))
20245         phii=phi(i)
20246 !         print *,i,itori,itori1
20247         gloci=0.0D0
20248 !C Regular cosine and sine terms
20249         do j=1,nterm_nucl(itori,itori1)
20250           v1ij=v1_nucl(j,itori,itori1)
20251           v2ij=v2_nucl(j,itori,itori1)
20252           cosphi=dcos(j*phii)
20253           sinphi=dsin(j*phii)
20254           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20255           if (energy_dec) etors_ii=etors_ii+&
20256                      v1ij*cosphi+v2ij*sinphi
20257           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20258         enddo
20259 !C Lorentz terms
20260 !C                         v1
20261 !C  E = SUM ----------------------------------- - v1
20262 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20263 !C
20264         cosphi=dcos(0.5d0*phii)
20265         sinphi=dsin(0.5d0*phii)
20266         do j=1,nlor_nucl(itori,itori1)
20267           vl1ij=vlor1_nucl(j,itori,itori1)
20268           vl2ij=vlor2_nucl(j,itori,itori1)
20269           vl3ij=vlor3_nucl(j,itori,itori1)
20270           pom=vl2ij*cosphi+vl3ij*sinphi
20271           pom1=1.0d0/(pom*pom+1.0d0)
20272           etors_nucl=etors_nucl+vl1ij*pom1
20273           if (energy_dec) etors_ii=etors_ii+ &
20274                      vl1ij*pom1
20275           pom=-pom*pom1*pom1
20276           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20277         enddo
20278 !C Subtract the constant term
20279         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20280           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20281               'etor',i,etors_ii-v0_nucl(itori,itori1)
20282         if (lprn) &
20283        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20284        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20285        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20286         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20287 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20288       enddo
20289       return
20290       end subroutine etor_nucl
20291 !------------------------------------------------------------
20292       subroutine epp_nucl_sub(evdw1,ees)
20293 !C
20294 !C This subroutine calculates the average interaction energy and its gradient
20295 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20296 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20297 !C The potential depends both on the distance of peptide-group centers and on
20298 !C the orientation of the CA-CA virtual bonds.
20299 !C
20300       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20301       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
20302       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20303                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20304                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20305       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20306                     dist_temp, dist_init,sss_grad,fac,evdw1ij
20307       integer xshift,yshift,zshift
20308       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20309       real(kind=8) :: ees,eesij
20310 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20311       real(kind=8) scal_el /0.5d0/
20312       t_eelecij=0.0d0
20313       ees=0.0D0
20314       evdw1=0.0D0
20315       ind=0
20316 !c
20317 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20318 !c
20319 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20320       do i=iatel_s_nucl,iatel_e_nucl
20321         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20322         dxi=dc(1,i)
20323         dyi=dc(2,i)
20324         dzi=dc(3,i)
20325         dx_normi=dc_norm(1,i)
20326         dy_normi=dc_norm(2,i)
20327         dz_normi=dc_norm(3,i)
20328         xmedi=c(1,i)+0.5d0*dxi
20329         ymedi=c(2,i)+0.5d0*dyi
20330         zmedi=c(3,i)+0.5d0*dzi
20331           xmedi=dmod(xmedi,boxxsize)
20332           if (xmedi.lt.0) xmedi=xmedi+boxxsize
20333           ymedi=dmod(ymedi,boxysize)
20334           if (ymedi.lt.0) ymedi=ymedi+boxysize
20335           zmedi=dmod(zmedi,boxzsize)
20336           if (zmedi.lt.0) zmedi=zmedi+boxzsize
20337
20338         do j=ielstart_nucl(i),ielend_nucl(i)
20339           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20340           ind=ind+1
20341           dxj=dc(1,j)
20342           dyj=dc(2,j)
20343           dzj=dc(3,j)
20344 !          xj=c(1,j)+0.5D0*dxj-xmedi
20345 !          yj=c(2,j)+0.5D0*dyj-ymedi
20346 !          zj=c(3,j)+0.5D0*dzj-zmedi
20347           xj=c(1,j)+0.5D0*dxj
20348           yj=c(2,j)+0.5D0*dyj
20349           zj=c(3,j)+0.5D0*dzj
20350           xj=mod(xj,boxxsize)
20351           if (xj.lt.0) xj=xj+boxxsize
20352           yj=mod(yj,boxysize)
20353           if (yj.lt.0) yj=yj+boxysize
20354           zj=mod(zj,boxzsize)
20355           if (zj.lt.0) zj=zj+boxzsize
20356       isubchap=0
20357       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20358       xj_safe=xj
20359       yj_safe=yj
20360       zj_safe=zj
20361       do xshift=-1,1
20362       do yshift=-1,1
20363       do zshift=-1,1
20364           xj=xj_safe+xshift*boxxsize
20365           yj=yj_safe+yshift*boxysize
20366           zj=zj_safe+zshift*boxzsize
20367           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20368           if(dist_temp.lt.dist_init) then
20369             dist_init=dist_temp
20370             xj_temp=xj
20371             yj_temp=yj
20372             zj_temp=zj
20373             isubchap=1
20374           endif
20375        enddo
20376        enddo
20377        enddo
20378        if (isubchap.eq.1) then
20379 !C          print *,i,j
20380           xj=xj_temp-xmedi
20381           yj=yj_temp-ymedi
20382           zj=zj_temp-zmedi
20383        else
20384           xj=xj_safe-xmedi
20385           yj=yj_safe-ymedi
20386           zj=zj_safe-zmedi
20387        endif
20388
20389           rij=xj*xj+yj*yj+zj*zj
20390 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20391           fac=(r0pp**2/rij)**3
20392           ev1=epspp*fac*fac
20393           ev2=epspp*fac
20394           evdw1ij=ev1-2*ev2
20395           fac=(-ev1-evdw1ij)/rij
20396 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20397           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20398           evdw1=evdw1+evdw1ij
20399 !C
20400 !C Calculate contributions to the Cartesian gradient.
20401 !C
20402           ggg(1)=fac*xj
20403           ggg(2)=fac*yj
20404           ggg(3)=fac*zj
20405           do k=1,3
20406             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20407             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20408           enddo
20409 !c phoshate-phosphate electrostatic interactions
20410           rij=dsqrt(rij)
20411           fac=1.0d0/rij
20412           eesij=dexp(-BEES*rij)*fac
20413 !          write (2,*)"fac",fac," eesijpp",eesij
20414           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
20415           ees=ees+eesij
20416 !c          fac=-eesij*fac
20417           fac=-(fac+BEES)*eesij*fac
20418           ggg(1)=fac*xj
20419           ggg(2)=fac*yj
20420           ggg(3)=fac*zj
20421 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
20422 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
20423 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
20424           do k=1,3
20425             gelpp(k,i)=gelpp(k,i)-ggg(k)
20426             gelpp(k,j)=gelpp(k,j)+ggg(k)
20427           enddo
20428         enddo ! j
20429       enddo   ! i
20430 !c      ees=332.0d0*ees
20431       ees=AEES*ees
20432       do i=nnt,nct
20433 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20434         do k=1,3
20435           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
20436 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
20437           gelpp(k,i)=AEES*gelpp(k,i)
20438         enddo
20439 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20440       enddo
20441 !c      write (2,*) "total EES",ees
20442       return
20443       end subroutine epp_nucl_sub
20444 !---------------------------------------------------------------------
20445       subroutine epsb(evdwpsb,eelpsb)
20446 !      use comm_locel
20447 !C
20448 !C This subroutine calculates the excluded-volume interaction energy between
20449 !C peptide-group centers and side chains and its gradient in virtual-bond and
20450 !C side-chain vectors.
20451 !C
20452       real(kind=8),dimension(3):: ggg
20453       integer :: i,iint,j,k,iteli,itypj,subchap
20454       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
20455                    e1,e2,evdwij,rij,evdwpsb,eelpsb
20456       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20457                     dist_temp, dist_init
20458       integer xshift,yshift,zshift
20459
20460 !cd    print '(a)','Enter ESCP'
20461 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
20462       eelpsb=0.0d0
20463       evdwpsb=0.0d0
20464 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
20465       do i=iatscp_s_nucl,iatscp_e_nucl
20466         if (itype(i,2).eq.ntyp1_molec(2) &
20467          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20468         xi=0.5D0*(c(1,i)+c(1,i+1))
20469         yi=0.5D0*(c(2,i)+c(2,i+1))
20470         zi=0.5D0*(c(3,i)+c(3,i+1))
20471           xi=mod(xi,boxxsize)
20472           if (xi.lt.0) xi=xi+boxxsize
20473           yi=mod(yi,boxysize)
20474           if (yi.lt.0) yi=yi+boxysize
20475           zi=mod(zi,boxzsize)
20476           if (zi.lt.0) zi=zi+boxzsize
20477
20478         do iint=1,nscp_gr_nucl(i)
20479
20480         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
20481           itypj=itype(j,2)
20482           if (itypj.eq.ntyp1_molec(2)) cycle
20483 !C Uncomment following three lines for SC-p interactions
20484 !c         xj=c(1,nres+j)-xi
20485 !c         yj=c(2,nres+j)-yi
20486 !c         zj=c(3,nres+j)-zi
20487 !C Uncomment following three lines for Ca-p interactions
20488 !          xj=c(1,j)-xi
20489 !          yj=c(2,j)-yi
20490 !          zj=c(3,j)-zi
20491           xj=c(1,j)
20492           yj=c(2,j)
20493           zj=c(3,j)
20494           xj=mod(xj,boxxsize)
20495           if (xj.lt.0) xj=xj+boxxsize
20496           yj=mod(yj,boxysize)
20497           if (yj.lt.0) yj=yj+boxysize
20498           zj=mod(zj,boxzsize)
20499           if (zj.lt.0) zj=zj+boxzsize
20500       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20501       xj_safe=xj
20502       yj_safe=yj
20503       zj_safe=zj
20504       subchap=0
20505       do xshift=-1,1
20506       do yshift=-1,1
20507       do zshift=-1,1
20508           xj=xj_safe+xshift*boxxsize
20509           yj=yj_safe+yshift*boxysize
20510           zj=zj_safe+zshift*boxzsize
20511           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20512           if(dist_temp.lt.dist_init) then
20513             dist_init=dist_temp
20514             xj_temp=xj
20515             yj_temp=yj
20516             zj_temp=zj
20517             subchap=1
20518           endif
20519        enddo
20520        enddo
20521        enddo
20522        if (subchap.eq.1) then
20523           xj=xj_temp-xi
20524           yj=yj_temp-yi
20525           zj=zj_temp-zi
20526        else
20527           xj=xj_safe-xi
20528           yj=yj_safe-yi
20529           zj=zj_safe-zi
20530        endif
20531
20532           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20533           fac=rrij**expon2
20534           e1=fac*fac*aad_nucl(itypj)
20535           e2=fac*bad_nucl(itypj)
20536           if (iabs(j-i) .le. 2) then
20537             e1=scal14*e1
20538             e2=scal14*e2
20539           endif
20540           evdwij=e1+e2
20541           evdwpsb=evdwpsb+evdwij
20542           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
20543              'evdw2',i,j,evdwij,"tu4"
20544 !C
20545 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
20546 !C
20547           fac=-(evdwij+e1)*rrij
20548           ggg(1)=xj*fac
20549           ggg(2)=yj*fac
20550           ggg(3)=zj*fac
20551           do k=1,3
20552             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
20553             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
20554           enddo
20555         enddo
20556
20557         enddo ! iint
20558       enddo ! i
20559       do i=1,nct
20560         do j=1,3
20561           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
20562           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
20563         enddo
20564       enddo
20565       return
20566       end subroutine epsb
20567
20568 !------------------------------------------------------
20569       subroutine esb_gb(evdwsb,eelsb)
20570       use comm_locel
20571       use calc_data_nucl
20572       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
20573       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
20574       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
20575       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20576                     dist_temp, dist_init,aa,bb,faclip,sig0ij
20577       integer :: ii
20578       logical lprn
20579       evdw=0.0D0
20580       eelsb=0.0d0
20581       ecorr=0.0d0
20582       evdwsb=0.0D0
20583       lprn=.false.
20584       ind=0
20585 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
20586       do i=iatsc_s_nucl,iatsc_e_nucl
20587         num_conti=0
20588         num_conti2=0
20589         itypi=itype(i,2)
20590 !        PRINT *,"I=",i,itypi
20591         if (itypi.eq.ntyp1_molec(2)) cycle
20592         itypi1=itype(i+1,2)
20593         xi=c(1,nres+i)
20594         yi=c(2,nres+i)
20595         zi=c(3,nres+i)
20596           xi=dmod(xi,boxxsize)
20597           if (xi.lt.0) xi=xi+boxxsize
20598           yi=dmod(yi,boxysize)
20599           if (yi.lt.0) yi=yi+boxysize
20600           zi=dmod(zi,boxzsize)
20601           if (zi.lt.0) zi=zi+boxzsize
20602
20603         dxi=dc_norm(1,nres+i)
20604         dyi=dc_norm(2,nres+i)
20605         dzi=dc_norm(3,nres+i)
20606         dsci_inv=vbld_inv(i+nres)
20607 !C
20608 !C Calculate SC interaction energy.
20609 !C
20610         do iint=1,nint_gr_nucl(i)
20611 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
20612           do j=istart_nucl(i,iint),iend_nucl(i,iint)
20613             ind=ind+1
20614 !            print *,"JESTEM"
20615             itypj=itype(j,2)
20616             if (itypj.eq.ntyp1_molec(2)) cycle
20617             dscj_inv=vbld_inv(j+nres)
20618             sig0ij=sigma_nucl(itypi,itypj)
20619             chi1=chi_nucl(itypi,itypj)
20620             chi2=chi_nucl(itypj,itypi)
20621             chi12=chi1*chi2
20622             chip1=chip_nucl(itypi,itypj)
20623             chip2=chip_nucl(itypj,itypi)
20624             chip12=chip1*chip2
20625 !            xj=c(1,nres+j)-xi
20626 !            yj=c(2,nres+j)-yi
20627 !            zj=c(3,nres+j)-zi
20628            xj=c(1,nres+j)
20629            yj=c(2,nres+j)
20630            zj=c(3,nres+j)
20631           xj=dmod(xj,boxxsize)
20632           if (xj.lt.0) xj=xj+boxxsize
20633           yj=dmod(yj,boxysize)
20634           if (yj.lt.0) yj=yj+boxysize
20635           zj=dmod(zj,boxzsize)
20636           if (zj.lt.0) zj=zj+boxzsize
20637       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20638       xj_safe=xj
20639       yj_safe=yj
20640       zj_safe=zj
20641       subchap=0
20642       do xshift=-1,1
20643       do yshift=-1,1
20644       do zshift=-1,1
20645           xj=xj_safe+xshift*boxxsize
20646           yj=yj_safe+yshift*boxysize
20647           zj=zj_safe+zshift*boxzsize
20648           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20649           if(dist_temp.lt.dist_init) then
20650             dist_init=dist_temp
20651             xj_temp=xj
20652             yj_temp=yj
20653             zj_temp=zj
20654             subchap=1
20655           endif
20656        enddo
20657        enddo
20658        enddo
20659        if (subchap.eq.1) then
20660           xj=xj_temp-xi
20661           yj=yj_temp-yi
20662           zj=zj_temp-zi
20663        else
20664           xj=xj_safe-xi
20665           yj=yj_safe-yi
20666           zj=zj_safe-zi
20667        endif
20668
20669             dxj=dc_norm(1,nres+j)
20670             dyj=dc_norm(2,nres+j)
20671             dzj=dc_norm(3,nres+j)
20672             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20673             rij=dsqrt(rrij)
20674 !C Calculate angle-dependent terms of energy and contributions to their
20675 !C derivatives.
20676             erij(1)=xj*rij
20677             erij(2)=yj*rij
20678             erij(3)=zj*rij
20679             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
20680             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
20681             om12=dxi*dxj+dyi*dyj+dzi*dzj
20682             call sc_angular_nucl
20683             sigsq=1.0D0/sigsq
20684             sig=sig0ij*dsqrt(sigsq)
20685             rij_shift=1.0D0/rij-sig+sig0ij
20686 !            print *,rij_shift,"rij_shift"
20687 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
20688 !c     &       " rij_shift",rij_shift
20689             if (rij_shift.le.0.0D0) then
20690               evdw=1.0D20
20691               return
20692             endif
20693             sigder=-sig*sigsq
20694 !c---------------------------------------------------------------
20695             rij_shift=1.0D0/rij_shift
20696             fac=rij_shift**expon
20697             e1=fac*fac*aa_nucl(itypi,itypj)
20698             e2=fac*bb_nucl(itypi,itypj)
20699             evdwij=eps1*eps2rt*(e1+e2)
20700 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
20701 !c     &       " e1",e1," e2",e2," evdwij",evdwij
20702             eps2der=evdwij
20703             evdwij=evdwij*eps2rt
20704             evdwsb=evdwsb+evdwij
20705             if (lprn) then
20706             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
20707             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
20708             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
20709              restyp(itypi,2),i,restyp(itypj,2),j, &
20710              epsi,sigm,chi1,chi2,chip1,chip2, &
20711              eps1,eps2rt**2,sig,sig0ij, &
20712              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
20713             evdwij
20714             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
20715             endif
20716
20717             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
20718                              'evdw',i,j,evdwij,"tu3"
20719
20720
20721 !C Calculate gradient components.
20722             e1=e1*eps1*eps2rt**2
20723             fac=-expon*(e1+evdwij)*rij_shift
20724             sigder=fac*sigder
20725             fac=rij*fac
20726 !c            fac=0.0d0
20727 !C Calculate the radial part of the gradient
20728             gg(1)=xj*fac
20729             gg(2)=yj*fac
20730             gg(3)=zj*fac
20731 !C Calculate angular part of the gradient.
20732             call sc_grad_nucl
20733             call eelsbij(eelij,num_conti2)
20734             if (energy_dec .and. &
20735            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
20736           write (istat,'(e14.5)') evdwij
20737             eelsb=eelsb+eelij
20738           enddo      ! j
20739         enddo        ! iint
20740         num_cont_hb(i)=num_conti2
20741       enddo          ! i
20742 !c      write (iout,*) "Number of loop steps in EGB:",ind
20743 !cccc      energy_dec=.false.
20744       return
20745       end subroutine esb_gb
20746 !-------------------------------------------------------------------------------
20747       subroutine eelsbij(eesij,num_conti2)
20748       use comm_locel
20749       use calc_data_nucl
20750       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
20751       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
20752       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20753                     dist_temp, dist_init,rlocshield,fracinbuf
20754       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
20755
20756 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20757       real(kind=8) scal_el /0.5d0/
20758       integer :: iteli,itelj,kkk,kkll,m,isubchap
20759       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
20760       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
20761       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
20762                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
20763                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
20764                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
20765                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
20766                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
20767                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
20768                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
20769       ind=ind+1
20770       itypi=itype(i,2)
20771       itypj=itype(j,2)
20772 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
20773       ael6i=ael6_nucl(itypi,itypj)
20774       ael3i=ael3_nucl(itypi,itypj)
20775       ael63i=ael63_nucl(itypi,itypj)
20776       ael32i=ael32_nucl(itypi,itypj)
20777 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
20778 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
20779       dxj=dc(1,j+nres)
20780       dyj=dc(2,j+nres)
20781       dzj=dc(3,j+nres)
20782       dx_normi=dc_norm(1,i+nres)
20783       dy_normi=dc_norm(2,i+nres)
20784       dz_normi=dc_norm(3,i+nres)
20785       dx_normj=dc_norm(1,j+nres)
20786       dy_normj=dc_norm(2,j+nres)
20787       dz_normj=dc_norm(3,j+nres)
20788 !c      xj=c(1,j)+0.5D0*dxj-xmedi
20789 !c      yj=c(2,j)+0.5D0*dyj-ymedi
20790 !c      zj=c(3,j)+0.5D0*dzj-zmedi
20791       if (ipot_nucl.ne.2) then
20792         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
20793         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
20794         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
20795       else
20796         cosa=om12
20797         cosb=om1
20798         cosg=om2
20799       endif
20800       r3ij=rij*rrij
20801       r6ij=r3ij*r3ij
20802       fac=cosa-3.0D0*cosb*cosg
20803       facfac=fac*fac
20804       fac1=3.0d0*(cosb*cosb+cosg*cosg)
20805       fac3=ael6i*r6ij
20806       fac4=ael3i*r3ij
20807       fac5=ael63i*r6ij
20808       fac6=ael32i*r6ij
20809 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
20810 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
20811       el1=fac3*(4.0D0+facfac-fac1)
20812       el2=fac4*fac
20813       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
20814       el4=fac6*facfac
20815       eesij=el1+el2+el3+el4
20816 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
20817       ees0ij=4.0D0+facfac-fac1
20818
20819       if (energy_dec) then
20820           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
20821           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
20822            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
20823            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
20824            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
20825           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
20826       endif
20827
20828 !C
20829 !C Calculate contributions to the Cartesian gradient.
20830 !C
20831       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
20832       fac1=fac
20833 !c      erij(1)=xj*rmij
20834 !c      erij(2)=yj*rmij
20835 !c      erij(3)=zj*rmij
20836 !*
20837 !* Radial derivatives. First process both termini of the fragment (i,j)
20838 !*
20839       ggg(1)=facel*xj
20840       ggg(2)=facel*yj
20841       ggg(3)=facel*zj
20842       do k=1,3
20843         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20844         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20845         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
20846         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
20847       enddo
20848 !*
20849 !* Angular part
20850 !*
20851       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
20852       fac4=-3.0D0*fac4
20853       fac3=-6.0D0*fac3
20854       fac5= 6.0d0*fac5
20855       fac6=-6.0d0*fac6
20856       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
20857        fac6*fac1*cosg
20858       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
20859        fac6*fac1*cosb
20860       do k=1,3
20861         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
20862         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
20863       enddo
20864       do k=1,3
20865         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
20866       enddo
20867       do k=1,3
20868         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
20869              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
20870              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20871         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
20872              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
20873              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20874         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20875         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20876       enddo
20877 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
20878        IF ( j.gt.i+1 .and.&
20879           num_conti.le.maxconts) THEN
20880 !C
20881 !C Calculate the contact function. The ith column of the array JCONT will
20882 !C contain the numbers of atoms that make contacts with the atom I (of numbers
20883 !C greater than I). The arrays FACONT and GACONT will contain the values of
20884 !C the contact function and its derivative.
20885         r0ij=2.20D0*sigma(itypi,itypj)
20886 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
20887         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
20888 !c        write (2,*) "fcont",fcont
20889         if (fcont.gt.0.0D0) then
20890           num_conti=num_conti+1
20891           num_conti2=num_conti2+1
20892
20893           if (num_conti.gt.maxconts) then
20894             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
20895                           ' will skip next contacts for this conf.'
20896           else
20897             jcont_hb(num_conti,i)=j
20898 !c            write (iout,*) "num_conti",num_conti,
20899 !c     &        " jcont_hb",jcont_hb(num_conti,i)
20900 !C Calculate contact energies
20901             cosa4=4.0D0*cosa
20902             wij=cosa-3.0D0*cosb*cosg
20903             cosbg1=cosb+cosg
20904             cosbg2=cosb-cosg
20905             fac3=dsqrt(-ael6i)*r3ij
20906 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
20907             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
20908             if (ees0tmp.gt.0) then
20909               ees0pij=dsqrt(ees0tmp)
20910             else
20911               ees0pij=0
20912             endif
20913             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
20914             if (ees0tmp.gt.0) then
20915               ees0mij=dsqrt(ees0tmp)
20916             else
20917               ees0mij=0
20918             endif
20919             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
20920             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
20921 !c            write (iout,*) "i",i," j",j,
20922 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
20923             ees0pij1=fac3/ees0pij
20924             ees0mij1=fac3/ees0mij
20925             fac3p=-3.0D0*fac3*rrij
20926             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
20927             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
20928             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
20929             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
20930             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
20931             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
20932             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
20933             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
20934             ecosap=ecosa1+ecosa2
20935             ecosbp=ecosb1+ecosb2
20936             ecosgp=ecosg1+ecosg2
20937             ecosam=ecosa1-ecosa2
20938             ecosbm=ecosb1-ecosb2
20939             ecosgm=ecosg1-ecosg2
20940 !C End diagnostics
20941             facont_hb(num_conti,i)=fcont
20942             fprimcont=fprimcont/rij
20943             do k=1,3
20944               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
20945               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
20946             enddo
20947             gggp(1)=gggp(1)+ees0pijp*xj
20948             gggp(2)=gggp(2)+ees0pijp*yj
20949             gggp(3)=gggp(3)+ees0pijp*zj
20950             gggm(1)=gggm(1)+ees0mijp*xj
20951             gggm(2)=gggm(2)+ees0mijp*yj
20952             gggm(3)=gggm(3)+ees0mijp*zj
20953 !C Derivatives due to the contact function
20954             gacont_hbr(1,num_conti,i)=fprimcont*xj
20955             gacont_hbr(2,num_conti,i)=fprimcont*yj
20956             gacont_hbr(3,num_conti,i)=fprimcont*zj
20957             do k=1,3
20958 !c
20959 !c Gradient of the correlation terms
20960 !c
20961               gacontp_hb1(k,num_conti,i)= &
20962              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
20963             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20964               gacontp_hb2(k,num_conti,i)= &
20965              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
20966             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20967               gacontp_hb3(k,num_conti,i)=gggp(k)
20968               gacontm_hb1(k,num_conti,i)= &
20969              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
20970             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20971               gacontm_hb2(k,num_conti,i)= &
20972              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
20973             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20974               gacontm_hb3(k,num_conti,i)=gggm(k)
20975             enddo
20976           endif
20977         endif
20978       ENDIF
20979       return
20980       end subroutine eelsbij
20981 !------------------------------------------------------------------
20982       subroutine sc_grad_nucl
20983       use comm_locel
20984       use calc_data_nucl
20985       real(kind=8),dimension(3) :: dcosom1,dcosom2
20986       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
20987       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
20988       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
20989       do k=1,3
20990         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
20991         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
20992       enddo
20993       do k=1,3
20994         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
20995       enddo
20996       do k=1,3
20997         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
20998                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
20999                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21000         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21001                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21002                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21003       enddo
21004 !C
21005 !C Calculate the components of the gradient in DC and X
21006 !C
21007       do l=1,3
21008         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21009         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21010       enddo
21011       return
21012       end subroutine sc_grad_nucl
21013 !-----------------------------------------------------------------------
21014       subroutine esb(esbloc)
21015 !C Calculate the local energy of a side chain and its derivatives in the
21016 !C corresponding virtual-bond valence angles THETA and the spherical angles
21017 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21018 !C added by Urszula Kozlowska. 07/11/2007
21019 !C
21020       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21021       real(kind=8),dimension(9):: x
21022      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21023       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21024       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21025       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21026        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21027        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21028        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21029        integer::it,nlobit,i,j,k
21030 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21031       delta=0.02d0*pi
21032       esbloc=0.0D0
21033       do i=loc_start_nucl,loc_end_nucl
21034         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21035         costtab(i+1) =dcos(theta(i+1))
21036         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21037         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21038         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21039         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21040         cosfac=dsqrt(cosfac2)
21041         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21042         sinfac=dsqrt(sinfac2)
21043         it=itype(i,2)
21044         if (it.eq.10) goto 1
21045
21046 !c
21047 !C  Compute the axes of tghe local cartesian coordinates system; store in
21048 !c   x_prime, y_prime and z_prime
21049 !c
21050         do j=1,3
21051           x_prime(j) = 0.00
21052           y_prime(j) = 0.00
21053           z_prime(j) = 0.00
21054         enddo
21055 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21056 !C     &   dc_norm(3,i+nres)
21057         do j = 1,3
21058           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21059           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21060         enddo
21061         do j = 1,3
21062           z_prime(j) = -uz(j,i-1)
21063 !           z_prime(j)=0.0
21064         enddo
21065
21066         xx=0.0d0
21067         yy=0.0d0
21068         zz=0.0d0
21069         do j = 1,3
21070           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21071           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21072           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21073         enddo
21074
21075         xxtab(i)=xx
21076         yytab(i)=yy
21077         zztab(i)=zz
21078          it=itype(i,2)
21079         do j = 1,9
21080           x(j) = sc_parmin_nucl(j,it)
21081         enddo
21082 #ifdef CHECK_COORD
21083 !Cc diagnostics - remove later
21084         xx1 = dcos(alph(2))
21085         yy1 = dsin(alph(2))*dcos(omeg(2))
21086         zz1 = -dsin(alph(2))*dsin(omeg(2))
21087         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21088          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21089          xx1,yy1,zz1
21090 !C,"  --- ", xx_w,yy_w,zz_w
21091 !c end diagnostics
21092 #endif
21093         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21094         esbloc = esbloc + sumene
21095         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21096 !        print *,"enecomp",sumene,sumene2
21097 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21098 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21099 #ifdef DEBUG
21100         write (2,*) "x",(x(k),k=1,9)
21101 !C
21102 !C This section to check the numerical derivatives of the energy of ith side
21103 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21104 !C #define DEBUG in the code to turn it on.
21105 !C
21106         write (2,*) "sumene               =",sumene
21107         aincr=1.0d-7
21108         xxsave=xx
21109         xx=xx+aincr
21110         write (2,*) xx,yy,zz
21111         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21112         de_dxx_num=(sumenep-sumene)/aincr
21113         xx=xxsave
21114         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21115         yysave=yy
21116         yy=yy+aincr
21117         write (2,*) xx,yy,zz
21118         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21119         de_dyy_num=(sumenep-sumene)/aincr
21120         yy=yysave
21121         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21122         zzsave=zz
21123         zz=zz+aincr
21124         write (2,*) xx,yy,zz
21125         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21126         de_dzz_num=(sumenep-sumene)/aincr
21127         zz=zzsave
21128         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21129         costsave=cost2tab(i+1)
21130         sintsave=sint2tab(i+1)
21131         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21132         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21133         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21134         de_dt_num=(sumenep-sumene)/aincr
21135         write (2,*) " t+ sumene from enesc=",sumenep,sumene
21136         cost2tab(i+1)=costsave
21137         sint2tab(i+1)=sintsave
21138 !C End of diagnostics section.
21139 #endif
21140 !C
21141 !C Compute the gradient of esc
21142 !C
21143         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21144         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21145         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21146         de_dtt=0.0d0
21147 #ifdef DEBUG
21148         write (2,*) "x",(x(k),k=1,9)
21149         write (2,*) "xx",xx," yy",yy," zz",zz
21150         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21151           " de_zz   ",de_zz," de_tt   ",de_tt
21152         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21153           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21154 #endif
21155 !C
21156        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21157        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21158        cosfac2xx=cosfac2*xx
21159        sinfac2yy=sinfac2*yy
21160        do k = 1,3
21161          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21162            vbld_inv(i+1)
21163          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21164            vbld_inv(i)
21165          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21166          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21167 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21168 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21169 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21170 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21171          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21172          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21173          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21174          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21175          dZZ_Ci1(k)=0.0d0
21176          dZZ_Ci(k)=0.0d0
21177          do j=1,3
21178            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21179            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21180          enddo
21181
21182          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21183          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21184          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21185 !c
21186          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21187          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21188        enddo
21189
21190        do k=1,3
21191          dXX_Ctab(k,i)=dXX_Ci(k)
21192          dXX_C1tab(k,i)=dXX_Ci1(k)
21193          dYY_Ctab(k,i)=dYY_Ci(k)
21194          dYY_C1tab(k,i)=dYY_Ci1(k)
21195          dZZ_Ctab(k,i)=dZZ_Ci(k)
21196          dZZ_C1tab(k,i)=dZZ_Ci1(k)
21197          dXX_XYZtab(k,i)=dXX_XYZ(k)
21198          dYY_XYZtab(k,i)=dYY_XYZ(k)
21199          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21200        enddo
21201        do k = 1,3
21202 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21203 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21204 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21205 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21206 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21207 !c     &    dt_dci(k)
21208 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21209 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21210          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21211          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21212          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21213          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21214          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21215          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21216 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21217        enddo
21218 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21219 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21220
21221 !C to check gradient call subroutine check_grad
21222
21223     1 continue
21224       enddo
21225       return
21226       end subroutine esb
21227 !=-------------------------------------------------------
21228       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21229 !      implicit none
21230       real(kind=8),dimension(9):: x(9)
21231        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21232       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21233       integer i
21234 !c      write (2,*) "enesc"
21235 !c      write (2,*) "x",(x(i),i=1,9)
21236 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21237       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21238         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21239         + x(9)*yy*zz
21240       enesc_nucl=sumene
21241       return
21242       end function enesc_nucl
21243 !-----------------------------------------------------------------------------
21244       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21245 #ifdef MPI
21246       include 'mpif.h'
21247       integer,parameter :: max_cont=2000
21248       integer,parameter:: max_dim=2*(8*3+6)
21249       integer, parameter :: msglen1=max_cont*max_dim
21250       integer,parameter :: msglen2=2*msglen1
21251       integer source,CorrelType,CorrelID,Error
21252       real(kind=8) :: buffer(max_cont,max_dim)
21253       integer status(MPI_STATUS_SIZE)
21254       integer :: ierror,nbytes
21255 #endif
21256       real(kind=8),dimension(3):: gx(3),gx1(3)
21257       real(kind=8) :: time00
21258       logical lprn,ldone
21259       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21260       real(kind=8) ecorr,ecorr3
21261       integer :: n_corr,n_corr1,mm,msglen
21262 !C Set lprn=.true. for debugging
21263       lprn=.false.
21264       n_corr=0
21265       n_corr1=0
21266 #ifdef MPI
21267       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21268
21269       if (nfgtasks.le.1) goto 30
21270       if (lprn) then
21271         write (iout,'(a)') 'Contact function values:'
21272         do i=nnt,nct-1
21273           write (iout,'(2i3,50(1x,i2,f5.2))')  &
21274          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21275          j=1,num_cont_hb(i))
21276         enddo
21277       endif
21278 !C Caution! Following code assumes that electrostatic interactions concerning
21279 !C a given atom are split among at most two processors!
21280       CorrelType=477
21281       CorrelID=fg_rank+1
21282       ldone=.false.
21283       do i=1,max_cont
21284         do j=1,max_dim
21285           buffer(i,j)=0.0D0
21286         enddo
21287       enddo
21288       mm=mod(fg_rank,2)
21289 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21290       if (mm) 20,20,10
21291    10 continue
21292 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21293       if (fg_rank.gt.0) then
21294 !C Send correlation contributions to the preceding processor
21295         msglen=msglen1
21296         nn=num_cont_hb(iatel_s_nucl)
21297         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21298 !c        write (*,*) 'The BUFFER array:'
21299 !c        do i=1,nn
21300 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21301 !c        enddo
21302         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21303           msglen=msglen2
21304           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21305 !C Clear the contacts of the atom passed to the neighboring processor
21306         nn=num_cont_hb(iatel_s_nucl+1)
21307 !c        do i=1,nn
21308 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21309 !c        enddo
21310             num_cont_hb(iatel_s_nucl)=0
21311         endif
21312 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21313 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21314 !cd   & ' msglen=',msglen
21315 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21316 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21317 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21318         time00=MPI_Wtime()
21319         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21320          CorrelType,FG_COMM,IERROR)
21321         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21322 !cd      write (iout,*) 'Processor ',fg_rank,
21323 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21324 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21325 !c        write (*,*) 'Processor ',fg_rank,
21326 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21327 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21328 !c        msglen=msglen1
21329       endif ! (fg_rank.gt.0)
21330       if (ldone) goto 30
21331       ldone=.true.
21332    20 continue
21333 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21334       if (fg_rank.lt.nfgtasks-1) then
21335 !C Receive correlation contributions from the next processor
21336         msglen=msglen1
21337         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21338 !cd      write (iout,*) 'Processor',fg_rank,
21339 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21340 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21341 !c        write (*,*) 'Processor',fg_rank,
21342 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21343 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21344         time00=MPI_Wtime()
21345         nbytes=-1
21346         do while (nbytes.le.0)
21347           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21348           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21349         enddo
21350 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21351         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21352          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21353         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21354 !c        write (*,*) 'Processor',fg_rank,
21355 !c     &' has received correlation contribution from processor',fg_rank+1,
21356 !c     & ' msglen=',msglen,' nbytes=',nbytes
21357 !c        write (*,*) 'The received BUFFER array:'
21358 !c        do i=1,max_cont
21359 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21360 !c        enddo
21361         if (msglen.eq.msglen1) then
21362           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21363         else if (msglen.eq.msglen2)  then
21364           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21365           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21366         else
21367           write (iout,*) &
21368       'ERROR!!!! message length changed while processing correlations.'
21369           write (*,*) &
21370       'ERROR!!!! message length changed while processing correlations.'
21371           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21372         endif ! msglen.eq.msglen1
21373       endif ! fg_rank.lt.nfgtasks-1
21374       if (ldone) goto 30
21375       ldone=.true.
21376       goto 10
21377    30 continue
21378 #endif
21379       if (lprn) then
21380         write (iout,'(a)') 'Contact function values:'
21381         do i=nnt_molec(2),nct_molec(2)-1
21382           write (iout,'(2i3,50(1x,i2,f5.2))') &
21383          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21384          j=1,num_cont_hb(i))
21385         enddo
21386       endif
21387       ecorr=0.0D0
21388       ecorr3=0.0d0
21389 !C Remove the loop below after debugging !!!
21390 !      do i=nnt_molec(2),nct_molec(2)
21391 !        do j=1,3
21392 !          gradcorr_nucl(j,i)=0.0D0
21393 !          gradxorr_nucl(j,i)=0.0D0
21394 !          gradcorr3_nucl(j,i)=0.0D0
21395 !          gradxorr3_nucl(j,i)=0.0D0
21396 !        enddo
21397 !      enddo
21398 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21399 !C Calculate the local-electrostatic correlation terms
21400       do i=iatsc_s_nucl,iatsc_e_nucl
21401         i1=i+1
21402         num_conti=num_cont_hb(i)
21403         num_conti1=num_cont_hb(i+1)
21404 !        print *,i,num_conti,num_conti1
21405         do jj=1,num_conti
21406           j=jcont_hb(jj,i)
21407           do kk=1,num_conti1
21408             j1=jcont_hb(kk,i1)
21409 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21410 !c     &         ' jj=',jj,' kk=',kk
21411             if (j1.eq.j+1 .or. j1.eq.j-1) then
21412 !C
21413 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21414 !C The system gains extra energy.
21415 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21416 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21417 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21418 !C
21419               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21420               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21421                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21422               n_corr=n_corr+1
21423             else if (j1.eq.j) then
21424 !C
21425 !C Contacts I-J and I-(J+1) occur simultaneously.
21426 !C The system loses extra energy.
21427 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21428 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21429 !C Need to implement full formulas 32 from Liwo et al., 1998.
21430 !C
21431 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21432 !c     &         ' jj=',jj,' kk=',kk
21433               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21434             endif
21435           enddo ! kk
21436           do kk=1,num_conti
21437             j1=jcont_hb(kk,i)
21438 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21439 !c     &         ' jj=',jj,' kk=',kk
21440             if (j1.eq.j+1) then
21441 !C Contacts I-J and (I+1)-J occur simultaneously.
21442 !C The system loses extra energy.
21443               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21444             endif ! j1==j+1
21445           enddo ! kk
21446         enddo ! jj
21447       enddo ! i
21448       return
21449       end subroutine multibody_hb_nucl
21450 !-----------------------------------------------------------
21451       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21452 !      implicit real*8 (a-h,o-z)
21453 !      include 'DIMENSIONS'
21454 !      include 'COMMON.IOUNITS'
21455 !      include 'COMMON.DERIV'
21456 !      include 'COMMON.INTERACT'
21457 !      include 'COMMON.CONTACTS'
21458       real(kind=8),dimension(3) :: gx,gx1
21459       logical :: lprn
21460 !el local variables
21461       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21462       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21463                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21464                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21465                    rlocshield
21466
21467       lprn=.false.
21468       eij=facont_hb(jj,i)
21469       ekl=facont_hb(kk,k)
21470       ees0pij=ees0p(jj,i)
21471       ees0pkl=ees0p(kk,k)
21472       ees0mij=ees0m(jj,i)
21473       ees0mkl=ees0m(kk,k)
21474       ekont=eij*ekl
21475       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21476 !      print *,"ehbcorr_nucl",ekont,ees
21477 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21478 !C Following 4 lines for diagnostics.
21479 !cd    ees0pkl=0.0D0
21480 !cd    ees0pij=1.0D0
21481 !cd    ees0mkl=0.0D0
21482 !cd    ees0mij=1.0D0
21483 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21484 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21485 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21486 !C Calculate the multi-body contribution to energy.
21487 !      ecorr_nucl=ecorr_nucl+ekont*ees
21488 !C Calculate multi-body contributions to the gradient.
21489       coeffpees0pij=coeffp*ees0pij
21490       coeffmees0mij=coeffm*ees0mij
21491       coeffpees0pkl=coeffp*ees0pkl
21492       coeffmees0mkl=coeffm*ees0mkl
21493       do ll=1,3
21494         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
21495        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21496        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21497         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
21498         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
21499         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21500         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
21501         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
21502         coeffmees0mij*gacontm_hb1(ll,kk,k))
21503         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
21504         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21505         coeffmees0mij*gacontm_hb2(ll,kk,k))
21506         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21507           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21508           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21509         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
21510         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
21511         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21512           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21513           coeffmees0mij*gacontm_hb3(ll,kk,k))
21514         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
21515         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
21516         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
21517         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
21518         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
21519         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
21520       enddo
21521       ehbcorr_nucl=ekont*ees
21522       return
21523       end function ehbcorr_nucl
21524 !-------------------------------------------------------------------------
21525
21526      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21527 !      implicit real*8 (a-h,o-z)
21528 !      include 'DIMENSIONS'
21529 !      include 'COMMON.IOUNITS'
21530 !      include 'COMMON.DERIV'
21531 !      include 'COMMON.INTERACT'
21532 !      include 'COMMON.CONTACTS'
21533       real(kind=8),dimension(3) :: gx,gx1
21534       logical :: lprn
21535 !el local variables
21536       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21537       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21538                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21539                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21540                    rlocshield
21541
21542       lprn=.false.
21543       eij=facont_hb(jj,i)
21544       ekl=facont_hb(kk,k)
21545       ees0pij=ees0p(jj,i)
21546       ees0pkl=ees0p(kk,k)
21547       ees0mij=ees0m(jj,i)
21548       ees0mkl=ees0m(kk,k)
21549       ekont=eij*ekl
21550       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21551 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21552 !C Following 4 lines for diagnostics.
21553 !cd    ees0pkl=0.0D0
21554 !cd    ees0pij=1.0D0
21555 !cd    ees0mkl=0.0D0
21556 !cd    ees0mij=1.0D0
21557 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21558 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21559 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21560 !C Calculate the multi-body contribution to energy.
21561 !      ecorr=ecorr+ekont*ees
21562 !C Calculate multi-body contributions to the gradient.
21563       coeffpees0pij=coeffp*ees0pij
21564       coeffmees0mij=coeffm*ees0mij
21565       coeffpees0pkl=coeffp*ees0pkl
21566       coeffmees0mkl=coeffm*ees0mkl
21567       do ll=1,3
21568         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
21569        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21570        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21571         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
21572         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
21573         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21574         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
21575         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
21576         coeffmees0mij*gacontm_hb1(ll,kk,k))
21577         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
21578         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21579         coeffmees0mij*gacontm_hb2(ll,kk,k))
21580         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21581           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21582           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21583         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
21584         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
21585         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21586           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21587           coeffmees0mij*gacontm_hb3(ll,kk,k))
21588         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
21589         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
21590         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
21591         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
21592         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
21593         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
21594       enddo
21595       ehbcorr3_nucl=ekont*ees
21596       return
21597       end function ehbcorr3_nucl
21598 #ifdef MPI
21599       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
21600       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21601       real(kind=8):: buffer(dimen1,dimen2)
21602       num_kont=num_cont_hb(atom)
21603       do i=1,num_kont
21604         do k=1,8
21605           do j=1,3
21606             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
21607           enddo ! j
21608         enddo ! k
21609         buffer(i,indx+25)=facont_hb(i,atom)
21610         buffer(i,indx+26)=ees0p(i,atom)
21611         buffer(i,indx+27)=ees0m(i,atom)
21612         buffer(i,indx+28)=d_cont(i,atom)
21613         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
21614       enddo ! i
21615       buffer(1,indx+30)=dfloat(num_kont)
21616       return
21617       end subroutine pack_buffer
21618 !c------------------------------------------------------------------------------
21619       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
21620       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21621       real(kind=8):: buffer(dimen1,dimen2)
21622 !      double precision zapas
21623 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
21624 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
21625 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
21626 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
21627       num_kont=buffer(1,indx+30)
21628       num_kont_old=num_cont_hb(atom)
21629       num_cont_hb(atom)=num_kont+num_kont_old
21630       do i=1,num_kont
21631         ii=i+num_kont_old
21632         do k=1,8
21633           do j=1,3
21634             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
21635           enddo ! j
21636         enddo ! k
21637         facont_hb(ii,atom)=buffer(i,indx+25)
21638         ees0p(ii,atom)=buffer(i,indx+26)
21639         ees0m(ii,atom)=buffer(i,indx+27)
21640         d_cont(i,atom)=buffer(i,indx+28)
21641         jcont_hb(ii,atom)=buffer(i,indx+29)
21642       enddo ! i
21643       return
21644       end subroutine unpack_buffer
21645 !c------------------------------------------------------------------------------
21646 #endif
21647       subroutine ecatcat(ecationcation)
21648         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
21649         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21650         r7,r4,ecationcation,k0,rcal
21651         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21652         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
21653         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21654         gg,r
21655
21656         ecationcation=0.0d0
21657         if (nres_molec(5).eq.0) return
21658         rcat0=3.472
21659         epscalc=0.05
21660         r06 = rcat0**6
21661         r012 = r06**2
21662         k0 = 332.0*(2.0*2.0)/80.0
21663         itmp=0
21664         do i=1,4
21665         itmp=itmp+nres_molec(i)
21666         enddo
21667         do i=itmp+1,itmp+nres_molec(i)-1
21668
21669         xi=c(1,i)
21670         yi=c(2,i)
21671         zi=c(3,i)
21672           xi=mod(xi,boxxsize)
21673           if (xi.lt.0) xi=xi+boxxsize
21674           yi=mod(yi,boxysize)
21675           if (yi.lt.0) yi=yi+boxysize
21676           zi=mod(zi,boxzsize)
21677           if (zi.lt.0) zi=zi+boxzsize
21678
21679           do j=i+1,itmp+nres_molec(5)
21680 !           print *,i,j,'catcat'
21681            xj=c(1,j)
21682            yj=c(2,j)
21683            zj=c(3,j)
21684           xj=dmod(xj,boxxsize)
21685           if (xj.lt.0) xj=xj+boxxsize
21686           yj=dmod(yj,boxysize)
21687           if (yj.lt.0) yj=yj+boxysize
21688           zj=dmod(zj,boxzsize)
21689           if (zj.lt.0) zj=zj+boxzsize
21690       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21691       xj_safe=xj
21692       yj_safe=yj
21693       zj_safe=zj
21694       subchap=0
21695       do xshift=-1,1
21696       do yshift=-1,1
21697       do zshift=-1,1
21698           xj=xj_safe+xshift*boxxsize
21699           yj=yj_safe+yshift*boxysize
21700           zj=zj_safe+zshift*boxzsize
21701           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21702           if(dist_temp.lt.dist_init) then
21703             dist_init=dist_temp
21704             xj_temp=xj
21705             yj_temp=yj
21706             zj_temp=zj
21707             subchap=1
21708           endif
21709        enddo
21710        enddo
21711        enddo
21712        if (subchap.eq.1) then
21713           xj=xj_temp-xi
21714           yj=yj_temp-yi
21715           zj=zj_temp-zi
21716        else
21717           xj=xj_safe-xi
21718           yj=yj_safe-yi
21719           zj=zj_safe-zi
21720        endif
21721        rcal =xj**2+yj**2+zj**2
21722         ract=sqrt(rcal)
21723 !        rcat0=3.472
21724 !        epscalc=0.05
21725 !        r06 = rcat0**6
21726 !        r012 = r06**2
21727 !        k0 = 332*(2*2)/80
21728         Evan1cat=epscalc*(r012/rcal**6)
21729         Evan2cat=epscalc*2*(r06/rcal**3)
21730         Eeleccat=k0/ract
21731         r7 = rcal**7
21732         r4 = rcal**4
21733         r(1)=xj
21734         r(2)=yj
21735         r(3)=zj
21736         do k=1,3
21737           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
21738           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
21739           dEeleccat(k)=-k0*r(k)/ract**3
21740         enddo
21741         do k=1,3
21742           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
21743           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
21744           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
21745         enddo
21746
21747         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
21748        enddo
21749        enddo
21750        return
21751        end subroutine ecatcat
21752 !---------------------------------------------------------------------------
21753        subroutine ecat_prot(ecation_prot)
21754        integer i,j,k,subchap,itmp,inum
21755         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21756         r7,r4,ecationcation
21757         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21758         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
21759         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
21760         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
21761         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
21762         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
21763         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
21764         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
21765         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
21766         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
21767         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip
21768         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21769         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
21770         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
21771         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
21772         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
21773         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
21774         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
21775         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
21776         dEvan1Cat
21777         real(kind=8),dimension(6) :: vcatprm
21778         ecation_prot=0.0d0
21779 ! first lets calculate interaction with peptide groups
21780         if (nres_molec(5).eq.0) return
21781          wconst=78
21782         wdip =1.092777950857032D2
21783         wdip=wdip/wconst
21784         wmodquad=-2.174122713004870D4
21785         wmodquad=wmodquad/wconst
21786         wquad1 = 3.901232068562804D1
21787         wquad1=wquad1/wconst
21788         wquad2 = 3
21789         wquad2=wquad2/wconst
21790         wvan1 = 0.1
21791         wvan2 = 6
21792         itmp=0
21793         do i=1,4
21794         itmp=itmp+nres_molec(i)
21795         enddo
21796         do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
21797 !         cycle
21798          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
21799         xi=0.5d0*(c(1,i)+c(1,i+1))
21800         yi=0.5d0*(c(2,i)+c(2,i+1))
21801         zi=0.5d0*(c(3,i)+c(3,i+1))
21802           xi=mod(xi,boxxsize)
21803           if (xi.lt.0) xi=xi+boxxsize
21804           yi=mod(yi,boxysize)
21805           if (yi.lt.0) yi=yi+boxysize
21806           zi=mod(zi,boxzsize)
21807           if (zi.lt.0) zi=zi+boxzsize
21808
21809          do j=itmp+1,itmp+nres_molec(5)
21810            xj=c(1,j)
21811            yj=c(2,j)
21812            zj=c(3,j)
21813           xj=dmod(xj,boxxsize)
21814           if (xj.lt.0) xj=xj+boxxsize
21815           yj=dmod(yj,boxysize)
21816           if (yj.lt.0) yj=yj+boxysize
21817           zj=dmod(zj,boxzsize)
21818           if (zj.lt.0) zj=zj+boxzsize
21819       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21820       xj_safe=xj
21821       yj_safe=yj
21822       zj_safe=zj
21823       subchap=0
21824       do xshift=-1,1
21825       do yshift=-1,1
21826       do zshift=-1,1
21827           xj=xj_safe+xshift*boxxsize
21828           yj=yj_safe+yshift*boxysize
21829           zj=zj_safe+zshift*boxzsize
21830           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21831           if(dist_temp.lt.dist_init) then
21832             dist_init=dist_temp
21833             xj_temp=xj
21834             yj_temp=yj
21835             zj_temp=zj
21836             subchap=1
21837           endif
21838        enddo
21839        enddo
21840        enddo
21841        if (subchap.eq.1) then
21842           xj=xj_temp-xi
21843           yj=yj_temp-yi
21844           zj=zj_temp-zi
21845        else
21846           xj=xj_safe-xi
21847           yj=yj_safe-yi
21848           zj=zj_safe-zi
21849        endif
21850 !       enddo
21851 !       enddo
21852        rcpm = sqrt(xj**2+yj**2+zj**2)
21853        drcp_norm(1)=xj/rcpm
21854        drcp_norm(2)=yj/rcpm
21855        drcp_norm(3)=zj/rcpm
21856        dcmag=0.0
21857        do k=1,3
21858        dcmag=dcmag+dc(k,i)**2
21859        enddo
21860        dcmag=dsqrt(dcmag)
21861        do k=1,3
21862          myd_norm(k)=dc(k,i)/dcmag
21863        enddo
21864         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
21865         drcp_norm(3)*myd_norm(3)
21866         rsecp = rcpm**2
21867         Ir = 1.0d0/rcpm
21868         Irsecp = 1.0d0/rsecp
21869         Irthrp = Irsecp/rcpm
21870         Irfourp = Irthrp/rcpm
21871         Irfiftp = Irfourp/rcpm
21872         Irsistp=Irfiftp/rcpm
21873         Irseven=Irsistp/rcpm
21874         Irtwelv=Irsistp*Irsistp
21875         Irthir=Irtwelv/rcpm
21876         sin2thet = (1-costhet*costhet)
21877         sinthet=sqrt(sin2thet)
21878         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
21879              *sin2thet
21880         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
21881              2*wvan2**6*Irsistp)
21882         ecation_prot = ecation_prot+E1+E2
21883         dE1dr = -2*costhet*wdip*Irthrp-&
21884          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
21885         dE2dr = 3*wquad1*wquad2*Irfourp-     &
21886           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
21887         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
21888         do k=1,3
21889           drdpep(k) = -drcp_norm(k)
21890           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
21891           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
21892           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
21893           dEddci(k) = dEdcos*dcosddci(k)
21894         enddo
21895         do k=1,3
21896         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
21897         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
21898         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
21899         enddo
21900        enddo ! j
21901        enddo ! i
21902 !------------------------------------------sidechains
21903         do i=1,nres_molec(1)
21904          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
21905 !         cycle
21906 !        print *,i,ecation_prot
21907         xi=(c(1,i+nres))
21908         yi=(c(2,i+nres))
21909         zi=(c(3,i+nres))
21910           xi=mod(xi,boxxsize)
21911           if (xi.lt.0) xi=xi+boxxsize
21912           yi=mod(yi,boxysize)
21913           if (yi.lt.0) yi=yi+boxysize
21914           zi=mod(zi,boxzsize)
21915           if (zi.lt.0) zi=zi+boxzsize
21916           do k=1,3
21917             cm1(k)=dc(k,i+nres)
21918           enddo
21919            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
21920          do j=itmp+1,itmp+nres_molec(5)
21921            xj=c(1,j)
21922            yj=c(2,j)
21923            zj=c(3,j)
21924           xj=dmod(xj,boxxsize)
21925           if (xj.lt.0) xj=xj+boxxsize
21926           yj=dmod(yj,boxysize)
21927           if (yj.lt.0) yj=yj+boxysize
21928           zj=dmod(zj,boxzsize)
21929           if (zj.lt.0) zj=zj+boxzsize
21930       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21931       xj_safe=xj
21932       yj_safe=yj
21933       zj_safe=zj
21934       subchap=0
21935       do xshift=-1,1
21936       do yshift=-1,1
21937       do zshift=-1,1
21938           xj=xj_safe+xshift*boxxsize
21939           yj=yj_safe+yshift*boxysize
21940           zj=zj_safe+zshift*boxzsize
21941           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21942           if(dist_temp.lt.dist_init) then
21943             dist_init=dist_temp
21944             xj_temp=xj
21945             yj_temp=yj
21946             zj_temp=zj
21947             subchap=1
21948           endif
21949        enddo
21950        enddo
21951        enddo
21952        if (subchap.eq.1) then
21953           xj=xj_temp-xi
21954           yj=yj_temp-yi
21955           zj=zj_temp-zi
21956        else
21957           xj=xj_safe-xi
21958           yj=yj_safe-yi
21959           zj=zj_safe-zi
21960        endif
21961 !       enddo
21962 !       enddo
21963          if(itype(i,1).eq.15.or.itype(i,1).eq.16) then
21964             if(itype(i,1).eq.16) then
21965             inum=1
21966             else
21967             inum=2
21968             endif
21969             do k=1,6
21970             vcatprm(k)=catprm(k,inum)
21971             enddo
21972             dASGL=catprm(7,inum)
21973              do k=1,3
21974                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
21975                 valpha(k)=c(k,i)
21976                 vcat(k)=c(k,j)
21977               enddo
21978                       do k=1,3
21979           dx(k) = vcat(k)-vcm(k)
21980         enddo
21981         do k=1,3
21982           v1(k)=(vcm(k)-valpha(k))
21983           v2(k)=(vcat(k)-valpha(k))
21984         enddo
21985         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
21986         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
21987         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
21988
21989 !  The weights of the energy function calculated from
21990 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
21991         wh2o=78
21992         wc = vcatprm(1)
21993         wc=wc/wh2o
21994         wdip =vcatprm(2)
21995         wdip=wdip/wh2o
21996         wquad1 =vcatprm(3)
21997         wquad1=wquad1/wh2o
21998         wquad2 = vcatprm(4)
21999         wquad2=wquad2/wh2o
22000         wquad2p = 1-wquad2
22001         wvan1 = vcatprm(5)
22002         wvan2 =vcatprm(6)
22003         opt = dx(1)**2+dx(2)**2
22004         rsecp = opt+dx(3)**2
22005         rs = sqrt(rsecp)
22006         rthrp = rsecp*rs
22007         rfourp = rthrp*rs
22008         rsixp = rfourp*rsecp
22009         reight=rsixp*rsecp
22010         Ir = 1.0d0/rs
22011         Irsecp = 1/rsecp
22012         Irthrp = Irsecp/rs
22013         Irfourp = Irthrp/rs
22014         Irsixp = 1/rsixp
22015         Ireight=1/reight
22016         Irtw=Irsixp*Irsixp
22017         Irthir=Irtw/rs
22018         Irfourt=Irthir/rs
22019         opt1 = (4*rs*dx(3)*wdip)
22020         opt2 = 6*rsecp*wquad1*opt
22021         opt3 = wquad1*wquad2p*Irsixp
22022         opt4 = (wvan1*wvan2**12)
22023         opt5 = opt4*12*Irfourt
22024         opt6 = 2*wvan1*wvan2**6
22025         opt7 = 6*opt6*Ireight
22026         opt8 = wdip/v1m
22027         opt10 = wdip/v2m
22028         opt11 = (rsecp*v2m)**2
22029         opt12 = (rsecp*v1m)**2
22030         opt14 = (v1m*v2m*rsecp)**2
22031         opt15 = -wquad1/v2m**2
22032         opt16 = (rthrp*(v1m*v2m)**2)**2
22033         opt17 = (v1m**2*rthrp)**2
22034         opt18 = -wquad1/rthrp
22035         opt19 = (v1m**2*v2m**2)**2
22036         Ec = wc*Ir
22037         do k=1,3
22038           dEcCat(k) = -(dx(k)*wc)*Irthrp
22039           dEcCm(k)=(dx(k)*wc)*Irthrp
22040           dEcCalp(k)=0.0d0
22041         enddo
22042         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22043         do k=1,3
22044           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
22045                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22046           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
22047                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22048           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
22049                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
22050                       *v1dpv2)/opt14
22051         enddo
22052         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22053         do k=1,3
22054           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
22055                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
22056                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22057           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
22058                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
22059                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22060           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22061                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
22062                         v1dpv2**2)/opt19
22063         enddo
22064         Equad2=wquad1*wquad2p*Irthrp
22065         do k=1,3
22066           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22067           dEquad2Cm(k)=3*dx(k)*rs*opt3
22068           dEquad2Calp(k)=0.0d0
22069         enddo
22070         Evan1=opt4*Irtw
22071         do k=1,3
22072           dEvan1Cat(k)=-dx(k)*opt5
22073           dEvan1Cm(k)=dx(k)*opt5
22074           dEvan1Calp(k)=0.0d0
22075         enddo
22076         Evan2=-opt6*Irsixp
22077         do k=1,3
22078           dEvan2Cat(k)=dx(k)*opt7
22079           dEvan2Cm(k)=-dx(k)*opt7
22080           dEvan2Calp(k)=0.0d0
22081         enddo
22082         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
22083 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
22084
22085         do k=1,3
22086           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
22087                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22088 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
22089           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
22090                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22091           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
22092                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22093         enddo
22094             dscmag = 0.0d0
22095             do k=1,3
22096               dscvec(k) = dc(k,i+nres)
22097               dscmag = dscmag+dscvec(k)*dscvec(k)
22098             enddo
22099             dscmag3 = dscmag
22100             dscmag = sqrt(dscmag)
22101             dscmag3 = dscmag3*dscmag
22102             constA = 1.0d0+dASGL/dscmag
22103             constB = 0.0d0
22104             do k=1,3
22105               constB = constB+dscvec(k)*dEtotalCm(k)
22106             enddo
22107             constB = constB*dASGL/dscmag3
22108             do k=1,3
22109               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22110               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22111                constA*dEtotalCm(k)-constB*dscvec(k)
22112 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
22113               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22114               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22115              enddo
22116         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
22117            if(itype(i,1).eq.14) then
22118             inum=3
22119             else
22120             inum=4
22121             endif
22122             do k=1,6
22123             vcatprm(k)=catprm(k,inum)
22124             enddo
22125             dASGL=catprm(7,inum)
22126              do k=1,3
22127                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22128                 valpha(k)=c(k,i)
22129                 vcat(k)=c(k,j)
22130               enddo
22131
22132         do k=1,3
22133           dx(k) = vcat(k)-vcm(k)
22134         enddo
22135         do k=1,3
22136           v1(k)=(vcm(k)-valpha(k))
22137           v2(k)=(vcat(k)-valpha(k))
22138         enddo
22139         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22140         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22141         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22142 !  The weights of the energy function calculated from
22143 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
22144         wh2o=78
22145         wdip =vcatprm(2)
22146         wdip=wdip/wh2o
22147         wquad1 =vcatprm(3)
22148         wquad1=wquad1/wh2o
22149         wquad2 = vcatprm(4)
22150         wquad2=wquad2/wh2o
22151         wquad2p = 1-wquad2
22152         wvan1 = vcatprm(5)
22153         wvan2 =vcatprm(6)
22154         opt = dx(1)**2+dx(2)**2
22155         rsecp = opt+dx(3)**2
22156         rs = sqrt(rsecp)
22157         rthrp = rsecp*rs
22158         rfourp = rthrp*rs
22159         rsixp = rfourp*rsecp
22160         reight=rsixp*rsecp
22161         Ir = 1.0d0/rs
22162         Irsecp = 1/rsecp
22163         Irthrp = Irsecp/rs
22164         Irfourp = Irthrp/rs
22165         Irsixp = 1/rsixp
22166         Ireight=1/reight
22167         Irtw=Irsixp*Irsixp
22168         Irthir=Irtw/rs
22169         Irfourt=Irthir/rs
22170         opt1 = (4*rs*dx(3)*wdip)
22171         opt2 = 6*rsecp*wquad1*opt
22172         opt3 = wquad1*wquad2p*Irsixp
22173         opt4 = (wvan1*wvan2**12)
22174         opt5 = opt4*12*Irfourt
22175         opt6 = 2*wvan1*wvan2**6
22176         opt7 = 6*opt6*Ireight
22177         opt8 = wdip/v1m
22178         opt10 = wdip/v2m
22179         opt11 = (rsecp*v2m)**2
22180         opt12 = (rsecp*v1m)**2
22181         opt14 = (v1m*v2m*rsecp)**2
22182         opt15 = -wquad1/v2m**2
22183         opt16 = (rthrp*(v1m*v2m)**2)**2
22184         opt17 = (v1m**2*rthrp)**2
22185         opt18 = -wquad1/rthrp
22186         opt19 = (v1m**2*v2m**2)**2
22187         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22188         do k=1,3
22189           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
22190                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22191          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
22192                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22193           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
22194                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
22195                       *v1dpv2)/opt14
22196         enddo
22197         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22198         do k=1,3
22199           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
22200                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
22201                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22202           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
22203                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
22204                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22205           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22206                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
22207                         v1dpv2**2)/opt19
22208         enddo
22209         Equad2=wquad1*wquad2p*Irthrp
22210         do k=1,3
22211           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22212           dEquad2Cm(k)=3*dx(k)*rs*opt3
22213           dEquad2Calp(k)=0.0d0
22214         enddo
22215         Evan1=opt4*Irtw
22216         do k=1,3
22217           dEvan1Cat(k)=-dx(k)*opt5
22218           dEvan1Cm(k)=dx(k)*opt5
22219           dEvan1Calp(k)=0.0d0
22220         enddo
22221         Evan2=-opt6*Irsixp
22222         do k=1,3
22223           dEvan2Cat(k)=dx(k)*opt7
22224           dEvan2Cm(k)=-dx(k)*opt7
22225           dEvan2Calp(k)=0.0d0
22226         enddo
22227          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
22228         do k=1,3
22229           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
22230                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22231           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
22232                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22233           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
22234                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22235         enddo
22236             dscmag = 0.0d0
22237             do k=1,3
22238               dscvec(k) = c(k,i+nres)-c(k,i)
22239               dscmag = dscmag+dscvec(k)*dscvec(k)
22240             enddo
22241             dscmag3 = dscmag
22242             dscmag = sqrt(dscmag)
22243             dscmag3 = dscmag3*dscmag
22244             constA = 1+dASGL/dscmag
22245             constB = 0.0d0
22246             do k=1,3
22247               constB = constB+dscvec(k)*dEtotalCm(k)
22248             enddo
22249             constB = constB*dASGL/dscmag3
22250             do k=1,3
22251               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22252               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22253                constA*dEtotalCm(k)-constB*dscvec(k)
22254               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22255               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22256              enddo
22257            else
22258             rcal = 0.0d0
22259             do k=1,3
22260               r(k) = c(k,j)-c(k,i+nres)
22261               rcal = rcal+r(k)*r(k)
22262             enddo
22263             ract=sqrt(rcal)
22264             rocal=1.5
22265             epscalc=0.2
22266             r0p=0.5*(rocal+sig0(itype(i,1)))
22267             r06 = r0p**6
22268             r012 = r06*r06
22269             Evan1=epscalc*(r012/rcal**6)
22270             Evan2=epscalc*2*(r06/rcal**3)
22271             r4 = rcal**4
22272             r7 = rcal**7
22273             do k=1,3
22274               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
22275               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
22276             enddo
22277             do k=1,3
22278               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
22279             enddo
22280                  ecation_prot = ecation_prot+ Evan1+Evan2
22281             do  k=1,3
22282                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22283                dEtotalCm(k)
22284               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
22285               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
22286              enddo
22287          endif ! 13-16 residues
22288        enddo !j
22289        enddo !i
22290        return
22291        end subroutine ecat_prot
22292
22293 !----------------------------------------------------------------------------
22294 !-----------------------------------------------------------------------------
22295 !-----------------------------------------------------------------------------
22296       end module energy