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 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 136       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 137         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 138       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 139         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 140         g_corr6_loc      !(maxvar)
 141       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 142       real(kind=8),dimension(:),allocatable :: gsccor_loc      !(maxres)
 143 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 144       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 145 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 146       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 147          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 148 !      integer :: nfl,icg
 149 !      common /deriv_loc/
 150       real(kind=8), dimension(:),allocatable :: fac_shield
 151       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 152 !      common /deriv_scloc/
 153       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 154        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 155        dZZ_XYZtab      !(3,maxres)
 156 !-----------------------------------------------------------------------------
 157 ! common.maxgrad
 158 !      common /maxgrad/
 159       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 160        gradb_max,ghpbc_max,&
 161        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 162        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 163        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 164        gsccorx_max,gsclocx_max
 165 !-----------------------------------------------------------------------------
 166 ! common.MD
 167 !      common /back_constr/
 168       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 169       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 170 !      common /qmeas/
 171       real(kind=8) :: Ucdfrag,Ucdpair
 172       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 173        dqwol,dxqwol      !(3,0:MAXRES)
 174 !-----------------------------------------------------------------------------
 175 ! common.sbridge
 176 !      common /dyn_ssbond/
 177       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 178 !-----------------------------------------------------------------------------
 179 ! common.sccor
 180 ! Parameters of the SCCOR term
 181 !      common/sccor/
 182       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 183        dcosomicron,domicron      !(3,3,3,maxres2)
 184 !-----------------------------------------------------------------------------
 185 ! common.vectors
 186 !      common /vectors/
 187       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 188       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 189 !-----------------------------------------------------------------------------
 190 ! common /przechowalnia/
 191       real(kind=8),dimension(:,:,:),allocatable :: zapas
 192       real(kind=8),dimension(:,:,:,:),allocatable ::zapas2 !(max_dim,maxconts,max_fg_procs)
 193       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 194 !-----------------------------------------------------------------------------
 195 !-----------------------------------------------------------------------------
 196 !
 197 !
 198 !-----------------------------------------------------------------------------
 199       contains
 200 !-----------------------------------------------------------------------------
 201 ! energy_p_new_barrier.F
 202 !-----------------------------------------------------------------------------
 203       subroutine etotal(energia)
 204 !      implicit real*8 (a-h,o-z)
 205 !      include 'DIMENSIONS'
 206       use MD_data
 207 #ifndef ISNAN
 208       external proc_proc
 209 #ifdef WINPGI
 210 !MS$ATTRIBUTES C ::  proc_proc
 211 #endif
 212 #endif
 213 #ifdef MPI
 214       include "mpif.h"
 215 #endif
 216 !      include 'COMMON.SETUP'
 217 !      include 'COMMON.IOUNITS'
 218       real(kind=8),dimension(0:n_ene) :: energia
 219 !      include 'COMMON.LOCAL'
 220 !      include 'COMMON.FFIELD'
 221 !      include 'COMMON.DERIV'
 222 !      include 'COMMON.INTERACT'
 223 !      include 'COMMON.SBRIDGE'
 224 !      include 'COMMON.CHAIN'
 225 !      include 'COMMON.VAR'
 226 !      include 'COMMON.MD'
 227 !      include 'COMMON.CONTROL'
 228 !      include 'COMMON.TIME1'
 229       real(kind=8) :: time00
 230 !el local variables
 231       integer :: n_corr,n_corr1,ierror
 232       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 233       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 234       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 235                       Eafmforce,ethetacnstr
 236       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 237 ! now energies for nulceic alone parameters
 238       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 239                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 240                       ecorr3_nucl
 241 #ifdef MPI
 242       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 243 ! shielding effect varibles for MPI
 244 !      real(kind=8)   fac_shieldbuf(maxres),
 245 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 246 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 247 !     & grad_shieldbuf(3,-1:maxres)
 248 !       integer ishield_listbuf(maxres),
 249 !     &shield_listbuf(maxcontsshi,maxres)
 250
 251 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 252 !     & " nfgtasks",nfgtasks
 253       if (nfgtasks.gt.1) then
 254         time00=MPI_Wtime()
 255 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 256         if (fg_rank.eq.0) then
 257           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 258 !          print *,"Processor",myrank," BROADCAST iorder"
 259 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 260 ! FG slaves as WEIGHTS array.
 261           weights_(1)=wsc
 262           weights_(2)=wscp
 263           weights_(3)=welec
 264           weights_(4)=wcorr
 265           weights_(5)=wcorr5
 266           weights_(6)=wcorr6
 267           weights_(7)=wel_loc
 268           weights_(8)=wturn3
 269           weights_(9)=wturn4
 270           weights_(10)=wturn6
 271           weights_(11)=wang
 272           weights_(12)=wscloc
 273           weights_(13)=wtor
 274           weights_(14)=wtor_d
 275           weights_(15)=wstrain
 276           weights_(16)=wvdwpp
 277           weights_(17)=wbond
 278           weights_(18)=scal14
 279           weights_(21)=wsccor
 280           weights_(26)=wvdwpp_nucl
 281           weights_(27)=welpp
 282           weights_(28)=wvdwpsb
 283           weights_(29)=welpsb
 284           weights_(30)=wvdwsb
 285           weights_(31)=welsb
 286           weights_(32)=wbond_nucl
 287           weights_(33)=wang_nucl
 288           weights_(34)=wsbloc
 289           weights_(35)=wtor_nucl
 290           weights_(36)=wtor_d_nucl
 291           weights_(37)=wcorr_nucl
 292           weights_(38)=wcorr3_nucl
 293
 294 ! FG Master broadcasts the WEIGHTS_ array
 295           call MPI_Bcast(weights_(1),n_ene,&
 296              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 297         else
 298 ! FG slaves receive the WEIGHTS array
 299           call MPI_Bcast(weights(1),n_ene,&
 300               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 301           wsc=weights(1)
 302           wscp=weights(2)
 303           welec=weights(3)
 304           wcorr=weights(4)
 305           wcorr5=weights(5)
 306           wcorr6=weights(6)
 307           wel_loc=weights(7)
 308           wturn3=weights(8)
 309           wturn4=weights(9)
 310           wturn6=weights(10)
 311           wang=weights(11)
 312           wscloc=weights(12)
 313           wtor=weights(13)
 314           wtor_d=weights(14)
 315           wstrain=weights(15)
 316           wvdwpp=weights(16)
 317           wbond=weights(17)
 318           scal14=weights(18)
 319           wsccor=weights(21)
 320           wvdwpp_nucl =weights(26)
 321           welpp  =weights(27)
 322           wvdwpsb=weights(28)
 323           welpsb =weights(29)
 324           wvdwsb =weights(30)
 325           welsb  =weights(31)
 326           wbond_nucl  =weights(32)
 327           wang_nucl   =weights(33)
 328           wsbloc =weights(34)
 329           wtor_nucl   =weights(35)
 330           wtor_d_nucl =weights(36)
 331           wcorr_nucl  =weights(37)
 332           wcorr3_nucl =weights(38)
 333
 334         endif
 335         time_Bcast=time_Bcast+MPI_Wtime()-time00
 336         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 337 !        call chainbuild_cart
 338       endif
 339 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 340 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 341 #else
 342 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 343 !        call int_from_cart1(.false.)
 344 !      endif
 345 #endif
 346 #ifdef TIMING
 347       time00=MPI_Wtime()
 348 #endif
 349 !
 350 ! Compute the side-chain and electrostatic interaction energy
 351 !        print *, "Before EVDW"
 352 !      goto (101,102,103,104,105,106) ipot
 353       select case(ipot)
 354 ! Lennard-Jones potential.
 355 !  101 call elj(evdw)
 356        case (1)
 357          call elj(evdw)
 358 !d    print '(a)','Exit ELJcall el'
 359 !      goto 107
 360 ! Lennard-Jones-Kihara potential (shifted).
 361 !  102 call eljk(evdw)
 362        case (2)
 363          call eljk(evdw)
 364 !      goto 107
 365 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 366 !  103 call ebp(evdw)
 367        case (3)
 368          call ebp(evdw)
 369 !      goto 107
 370 ! Gay-Berne potential (shifted LJ, angular dependence).
 371 !  104 call egb(evdw)
 372        case (4)
 373          call egb(evdw)
 374 !      goto 107
 375 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 376 !  105 call egbv(evdw)
 377        case (5)
 378          call egbv(evdw)
 379 !      goto 107
 380 ! Soft-sphere potential
 381 !  106 call e_softsphere(evdw)
 382        case (6)
 383          call e_softsphere(evdw)
 384 !
 385 ! Calculate electrostatic (H-bonding) energy of the main chain.
 386 !
 387 !  107 continue
 388        case default
 389          write(iout,*)"Wrong ipot"
 390 !         return
 391 !   50 continue
 392       end select
 393 !      continue
 394 !        print *,"after EGB"
 395 ! shielding effect
 396        if (shield_mode.eq.2) then
 397                  call set_shield_fac2
 398        endif
 399 !       print *,"AFTER EGB",ipot,evdw
 400 !mc
 401 !mc Sep-06: egb takes care of dynamic ss bonds too
 402 !mc
 403 !      if (dyn_ss) call dyn_set_nss
 404 !      print *,"Processor",myrank," computed USCSC"
 405 #ifdef TIMING
 406       time01=MPI_Wtime()
 407 #endif
 408       call vec_and_deriv
 409 #ifdef TIMING
 410       time_vec=time_vec+MPI_Wtime()-time01
 411 #endif
 412 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 413       if (ipot.lt.6) then
 414 #ifdef SPLITELE
 415 !         print *,"after ipot if", ipot
 416          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 417              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 418              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 419              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 420 #else
 421          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 422              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 423              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 424              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 425 #endif
 426 !            print *,"just befor eelec call"
 427             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 428 !         write (iout,*) "ELEC calc"
 429          else
 430             ees=0.0d0
 431             evdw1=0.0d0
 432             eel_loc=0.0d0
 433             eello_turn3=0.0d0
 434             eello_turn4=0.0d0
 435          endif
 436       else
 437 !        write (iout,*) "Soft-spheer ELEC potential"
 438         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 439          eello_turn4)
 440       endif
 441 !      print *,"Processor",myrank," computed UELEC"
 442 !
 443 ! Calculate excluded-volume interaction energy between peptide groups
 444 ! and side chains.
 445 !
 446 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 447
 448       if (ipot.lt.6) then
 449        if(wscp.gt.0d0) then
 450         call escp(evdw2,evdw2_14)
 451        else
 452         evdw2=0
 453         evdw2_14=0
 454        endif
 455       else
 456 !        write (iout,*) "Soft-sphere SCP potential"
 457         call escp_soft_sphere(evdw2,evdw2_14)
 458       endif
 459 !       write(iout,*) "in etotal before ebond",ipot
 460
 461 !
 462 ! Calculate the bond-stretching energy
 463 !
 464       call ebond(estr)
 465 !       print *,"EBOND",estr
 466 !       write(iout,*) "in etotal afer ebond",ipot
 467
 468 !
 469 ! Calculate the disulfide-bridge and other energy and the contributions
 470 ! from other distance constraints.
 471 !      print *,'Calling EHPB'
 472       call edis(ehpb)
 473 !elwrite(iout,*) "in etotal afer edis",ipot
 474 !      print *,'EHPB exitted succesfully.'
 475 !
 476 ! Calculate the virtual-bond-angle energy.
 477 !
 478       if (wang.gt.0d0) then
 479         call ebend(ebe,ethetacnstr)
 480       else
 481         ebe=0
 482         ethetacnstr=0
 483       endif
 484 !      print *,"Processor",myrank," computed UB"
 485 !
 486 ! Calculate the SC local energy.
 487 !
 488       call esc(escloc)
 489 !elwrite(iout,*) "in etotal afer esc",ipot
 490 !      print *,"Processor",myrank," computed USC"
 491 !
 492 ! Calculate the virtual-bond torsional energy.
 493 !
 494 !d    print *,'nterm=',nterm
 495       if (wtor.gt.0) then
 496        call etor(etors,edihcnstr)
 497       else
 498        etors=0
 499        edihcnstr=0
 500       endif
 501 !      print *,"Processor",myrank," computed Utor"
 502 !
 503 ! 6/23/01 Calculate double-torsional energy
 504 !
 505 !elwrite(iout,*) "in etotal",ipot
 506       if (wtor_d.gt.0) then
 507        call etor_d(etors_d)
 508       else
 509        etors_d=0
 510       endif
 511 !      print *,"Processor",myrank," computed Utord"
 512 !
 513 ! 21/5/07 Calculate local sicdechain correlation energy
 514 !
 515       if (wsccor.gt.0.0d0) then
 516         call eback_sc_corr(esccor)
 517       else
 518         esccor=0.0d0
 519       endif
 520 !      print *,"Processor",myrank," computed Usccorr"
 521 !
 522 ! 12/1/95 Multi-body terms
 523 !
 524       n_corr=0
 525       n_corr1=0
 526       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 527           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 528          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 529 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 530 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 531       else
 532          ecorr=0.0d0
 533          ecorr5=0.0d0
 534          ecorr6=0.0d0
 535          eturn6=0.0d0
 536       endif
 537 !elwrite(iout,*) "in etotal",ipot
 538       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 539          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 540 !d         write (iout,*) "multibody_hb ecorr",ecorr
 541       endif
 542 !elwrite(iout,*) "afeter  multibody hb"
 543
 544 !      print *,"Processor",myrank," computed Ucorr"
 545 !
 546 ! If performing constraint dynamics, call the constraint energy
 547 !  after the equilibration time
 548       if(usampl.and.totT.gt.eq_time) then
 549 !elwrite(iout,*) "afeter  multibody hb"
 550          call EconstrQ
 551 !elwrite(iout,*) "afeter  multibody hb"
 552          call Econstr_back
 553 !elwrite(iout,*) "afeter  multibody hb"
 554       else
 555          Uconst=0.0d0
 556          Uconst_back=0.0d0
 557       endif
 558       call flush(iout)
 559 !         write(iout,*) "after Econstr"
 560
 561       if (wliptran.gt.0) then
 562 !        print *,"PRZED WYWOLANIEM"
 563         call Eliptransfer(eliptran)
 564       else
 565        eliptran=0.0d0
 566       endif
 567       if (fg_rank.eq.0) then
 568       if (AFMlog.gt.0) then
 569         call AFMforce(Eafmforce)
 570       else if (selfguide.gt.0) then
 571         call AFMvel(Eafmforce)
 572       endif
 573       endif
 574       if (tubemode.eq.1) then
 575        call calctube(etube)
 576       else if (tubemode.eq.2) then
 577        call calctube2(etube)
 578       elseif (tubemode.eq.3) then
 579        call calcnano(etube)
 580       else
 581        etube=0.0d0
 582       endif
 583 !--------------------------------------------------------
 584 !      print *,"before",ees,evdw1,ecorr
 585       call ebond_nucl(estr_nucl)
 586       call ebend_nucl(ebe_nucl)
 587       call etor_nucl(etors_nucl)
 588       call esb_gb(evdwsb,eelsb)
 589       call epp_nucl_sub(evdwpp,eespp)
 590       call epsb(evdwpsb,eelpsb)
 591       call esb(esbloc)
 592       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 593
 594 !      print *,"after ebend", ebe_nucl
 595 #ifdef TIMING
 596       time_enecalc=time_enecalc+MPI_Wtime()-time00
 597 #endif
 598 !      print *,"Processor",myrank," computed Uconstr"
 599 #ifdef TIMING
 600       time00=MPI_Wtime()
 601 #endif
 602 !
 603 ! Sum the energies
 604 !
 605       energia(1)=evdw
 606 #ifdef SCP14
 607       energia(2)=evdw2-evdw2_14
 608       energia(18)=evdw2_14
 609 #else
 610       energia(2)=evdw2
 611       energia(18)=0.0d0
 612 #endif
 613 #ifdef SPLITELE
 614       energia(3)=ees
 615       energia(16)=evdw1
 616 #else
 617       energia(3)=ees+evdw1
 618       energia(16)=0.0d0
 619 #endif
 620       energia(4)=ecorr
 621       energia(5)=ecorr5
 622       energia(6)=ecorr6
 623       energia(7)=eel_loc
 624       energia(8)=eello_turn3
 625       energia(9)=eello_turn4
 626       energia(10)=eturn6
 627       energia(11)=ebe
 628       energia(12)=escloc
 629       energia(13)=etors
 630       energia(14)=etors_d
 631       energia(15)=ehpb
 632       energia(19)=edihcnstr
 633       energia(17)=estr
 634       energia(20)=Uconst+Uconst_back
 635       energia(21)=esccor
 636       energia(22)=eliptran
 637       energia(23)=Eafmforce
 638       energia(24)=ethetacnstr
 639       energia(25)=etube
 640 !---------------------------------------------------------------
 641       energia(26)=evdwpp
 642       energia(27)=eespp
 643       energia(28)=evdwpsb
 644       energia(29)=eelpsb
 645       energia(30)=evdwsb
 646       energia(31)=eelsb
 647       energia(32)=estr_nucl
 648       energia(33)=ebe_nucl
 649       energia(34)=esbloc
 650       energia(35)=etors_nucl
 651       energia(36)=etors_d_nucl
 652       energia(37)=ecorr_nucl
 653       energia(38)=ecorr3_nucl
 654 !----------------------------------------------------------------------
 655 !    Here are the energies showed per procesor if the are more processors
 656 !    per molecule then we sum it up in sum_energy subroutine
 657 !      print *," Processor",myrank," calls SUM_ENERGY"
 658       call sum_energy(energia,.true.)
 659       if (dyn_ss) call dyn_set_nss
 660 !      print *," Processor",myrank," left SUM_ENERGY"
 661 #ifdef TIMING
 662       time_sumene=time_sumene+MPI_Wtime()-time00
 663 #endif
 664 !el        call enerprint(energia)
 665 !elwrite(iout,*)"finish etotal"
 666       return
 667       end subroutine etotal
 668 !-----------------------------------------------------------------------------
 669       subroutine sum_energy(energia,reduce)
 670 !      implicit real*8 (a-h,o-z)
 671 !      include 'DIMENSIONS'
 672 #ifndef ISNAN
 673       external proc_proc
 674 #ifdef WINPGI
 675 !MS$ATTRIBUTES C ::  proc_proc
 676 #endif
 677 #endif
 678 #ifdef MPI
 679       include "mpif.h"
 680 #endif
 681 !      include 'COMMON.SETUP'
 682 !      include 'COMMON.IOUNITS'
 683       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 684 !      include 'COMMON.FFIELD'
 685 !      include 'COMMON.DERIV'
 686 !      include 'COMMON.INTERACT'
 687 !      include 'COMMON.SBRIDGE'
 688 !      include 'COMMON.CHAIN'
 689 !      include 'COMMON.VAR'
 690 !      include 'COMMON.CONTROL'
 691 !      include 'COMMON.TIME1'
 692       logical :: reduce
 693       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 694       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 695       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 696         eliptran,etube, Eafmforce,ethetacnstr
 697       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 698                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 699                       ecorr3_nucl
 700
 701       integer :: i
 702 #ifdef MPI
 703       integer :: ierr
 704       real(kind=8) :: time00
 705       if (nfgtasks.gt.1 .and. reduce) then
 706
 707 #ifdef DEBUG
 708         write (iout,*) "energies before REDUCE"
 709         call enerprint(energia)
 710         call flush(iout)
 711 #endif
 712         do i=0,n_ene
 713           enebuff(i)=energia(i)
 714         enddo
 715         time00=MPI_Wtime()
 716         call MPI_Barrier(FG_COMM,IERR)
 717         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 718         time00=MPI_Wtime()
 719         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 720           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 721 #ifdef DEBUG
 722         write (iout,*) "energies after REDUCE"
 723         call enerprint(energia)
 724         call flush(iout)
 725 #endif
 726         time_Reduce=time_Reduce+MPI_Wtime()-time00
 727       endif
 728       if (fg_rank.eq.0) then
 729 #endif
 730       evdw=energia(1)
 731 #ifdef SCP14
 732       evdw2=energia(2)+energia(18)
 733       evdw2_14=energia(18)
 734 #else
 735       evdw2=energia(2)
 736 #endif
 737 #ifdef SPLITELE
 738       ees=energia(3)
 739       evdw1=energia(16)
 740 #else
 741       ees=energia(3)
 742       evdw1=0.0d0
 743 #endif
 744       ecorr=energia(4)
 745       ecorr5=energia(5)
 746       ecorr6=energia(6)
 747       eel_loc=energia(7)
 748       eello_turn3=energia(8)
 749       eello_turn4=energia(9)
 750       eturn6=energia(10)
 751       ebe=energia(11)
 752       escloc=energia(12)
 753       etors=energia(13)
 754       etors_d=energia(14)
 755       ehpb=energia(15)
 756       edihcnstr=energia(19)
 757       estr=energia(17)
 758       Uconst=energia(20)
 759       esccor=energia(21)
 760       eliptran=energia(22)
 761       Eafmforce=energia(23)
 762       ethetacnstr=energia(24)
 763       etube=energia(25)
 764       evdwpp=energia(26)
 765       eespp=energia(27)
 766       evdwpsb=energia(28)
 767       eelpsb=energia(29)
 768       evdwsb=energia(30)
 769       eelsb=energia(31)
 770       estr_nucl=energia(32)
 771       ebe_nucl=energia(33)
 772       esbloc=energia(34)
 773       etors_nucl=energia(35)
 774       etors_d_nucl=energia(36)
 775       ecorr_nucl=energia(37)
 776       ecorr3_nucl=energia(38)
 777
 778
 779 #ifdef SPLITELE
 780       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 781        +wang*ebe+wtor*etors+wscloc*escloc &
 782        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 783        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 784        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 785        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 786        +Eafmforce+ethetacnstr  &
 787        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 788        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 789        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 790        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl
 791 #else
 792       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 793        +wang*ebe+wtor*etors+wscloc*escloc &
 794        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 795        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 796        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 797        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 798        +Eafmforce+ethetacnstr &
 799        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 800        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 801        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 802        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl
 803 #endif
 804       energia(0)=etot
 805 ! detecting NaNQ
 806 #ifdef ISNAN
 807 #ifdef AIX
 808       if (isnan(etot).ne.0) energia(0)=1.0d+99
 809 #else
 810       if (isnan(etot)) energia(0)=1.0d+99
 811 #endif
 812 #else
 813       i=0
 814 #ifdef WINPGI
 815       idumm=proc_proc(etot,i)
 816 #else
 817       call proc_proc(etot,i)
 818 #endif
 819       if(i.eq.1)energia(0)=1.0d+99
 820 #endif
 821 #ifdef MPI
 822       endif
 823 #endif
 824 !      call enerprint(energia)
 825       call flush(iout)
 826       return
 827       end subroutine sum_energy
 828 !-----------------------------------------------------------------------------
 829       subroutine rescale_weights(t_bath)
 830 !      implicit real*8 (a-h,o-z)
 831 #ifdef MPI
 832       include 'mpif.h'
 833 #endif
 834 !      include 'DIMENSIONS'
 835 !      include 'COMMON.IOUNITS'
 836 !      include 'COMMON.FFIELD'
 837 !      include 'COMMON.SBRIDGE'
 838       real(kind=8) :: kfac=2.4d0
 839       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 840 !el local variables
 841       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 842       real(kind=8) :: T0=3.0d2
 843       integer :: ierror
 844 !      facT=temp0/t_bath
 845 !      facT=2*temp0/(t_bath+temp0)
 846       if (rescale_mode.eq.0) then
 847         facT(1)=1.0d0
 848         facT(2)=1.0d0
 849         facT(3)=1.0d0
 850         facT(4)=1.0d0
 851         facT(5)=1.0d0
 852         facT(6)=1.0d0
 853       else if (rescale_mode.eq.1) then
 854         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 855         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 856         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 857         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 858         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 859 #ifdef WHAM_RUN
 860 !#if defined(WHAM_RUN) || defined(CLUSTER)
 861 #if defined(FUNCTH)
 862 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 863         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 864 #elif defined(FUNCT)
 865         facT(6)=t_bath/T0
 866 #else
 867         facT(6)=1.0d0
 868 #endif
 869 #endif
 870       else if (rescale_mode.eq.2) then
 871         x=t_bath/temp0
 872         x2=x*x
 873         x3=x2*x
 874         x4=x3*x
 875         x5=x4*x
 876         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 877         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 878         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 879         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 880         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 881 #ifdef WHAM_RUN
 882 !#if defined(WHAM_RUN) || defined(CLUSTER)
 883 #if defined(FUNCTH)
 884         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 885 #elif defined(FUNCT)
 886         facT(6)=t_bath/T0
 887 #else
 888         facT(6)=1.0d0
 889 #endif
 890 #endif
 891       else
 892         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 893         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 894 #ifdef MPI
 895        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 896 #endif
 897        stop 555
 898       endif
 899       welec=weights(3)*fact(1)
 900       wcorr=weights(4)*fact(3)
 901       wcorr5=weights(5)*fact(4)
 902       wcorr6=weights(6)*fact(5)
 903       wel_loc=weights(7)*fact(2)
 904       wturn3=weights(8)*fact(2)
 905       wturn4=weights(9)*fact(3)
 906       wturn6=weights(10)*fact(5)
 907       wtor=weights(13)*fact(1)
 908       wtor_d=weights(14)*fact(2)
 909       wsccor=weights(21)*fact(1)
 910
 911       return
 912       end subroutine rescale_weights
 913 !-----------------------------------------------------------------------------
 914       subroutine enerprint(energia)
 915 !      implicit real*8 (a-h,o-z)
 916 !      include 'DIMENSIONS'
 917 !      include 'COMMON.IOUNITS'
 918 !      include 'COMMON.FFIELD'
 919 !      include 'COMMON.SBRIDGE'
 920 !      include 'COMMON.MD'
 921       real(kind=8) :: energia(0:n_ene)
 922 !el local variables
 923       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 924       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 925       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
 926        etube,ethetacnstr,Eafmforce
 927       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 928                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 929                       ecorr3_nucl
 930
 931       etot=energia(0)
 932       evdw=energia(1)
 933       evdw2=energia(2)
 934 #ifdef SCP14
 935       evdw2=energia(2)+energia(18)
 936 #else
 937       evdw2=energia(2)
 938 #endif
 939       ees=energia(3)
 940 #ifdef SPLITELE
 941       evdw1=energia(16)
 942 #endif
 943       ecorr=energia(4)
 944       ecorr5=energia(5)
 945       ecorr6=energia(6)
 946       eel_loc=energia(7)
 947       eello_turn3=energia(8)
 948       eello_turn4=energia(9)
 949       eello_turn6=energia(10)
 950       ebe=energia(11)
 951       escloc=energia(12)
 952       etors=energia(13)
 953       etors_d=energia(14)
 954       ehpb=energia(15)
 955       edihcnstr=energia(19)
 956       estr=energia(17)
 957       Uconst=energia(20)
 958       esccor=energia(21)
 959       eliptran=energia(22)
 960       Eafmforce=energia(23)
 961       ethetacnstr=energia(24)
 962       etube=energia(25)
 963       evdwpp=energia(26)
 964       eespp=energia(27)
 965       evdwpsb=energia(28)
 966       eelpsb=energia(29)
 967       evdwsb=energia(30)
 968       eelsb=energia(31)
 969       estr_nucl=energia(32)
 970       ebe_nucl=energia(33)
 971       esbloc=energia(34)
 972       etors_nucl=energia(35)
 973       etors_d_nucl=energia(36)
 974       ecorr_nucl=energia(37)
 975       ecorr3_nucl=energia(38)
 976
 977 #ifdef SPLITELE
 978       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
 979         estr,wbond,ebe,wang,&
 980         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 981         ecorr,wcorr,&
 982         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 983         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
 984         edihcnstr,ethetacnstr,ebr*nss,&
 985         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
 986         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
 987         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
 988         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
 989         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
 990         ecorr3_nucl,wcorr3_nucl, &
 991         etot
 992    10 format (/'Virtual-chain energies:'// &
 993        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 994        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 995        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 996        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
 997        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 998        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 999        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1000        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1001        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1002        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1003        ' (SS bridges & dist. cnstr.)'/ &
1004        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1005        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1006        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1007        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1008        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1009        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1010        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1011        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1012        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1013        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1014        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1015        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1016        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1017        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1018        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1019        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1020        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1021        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1022        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1023        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1024        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1025        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1026        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1027        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1028        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1029        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1030        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1031        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1032        'ETOT=  ',1pE16.6,' (total)')
1033 #else
1034       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1035         estr,wbond,ebe,wang,&
1036         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1037         ecorr,wcorr,&
1038         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1039         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1040         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
1041         etube,wtube, &
1042         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1043         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1044         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1045         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1046         ecorr3_nucl,wcorr3_nucl, &
1047         etot
1048    10 format (/'Virtual-chain energies:'// &
1049        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1050        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1051        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1052        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1053        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1054        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1055        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1056        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1057        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1058        ' (SS bridges & dist. cnstr.)'/ &
1059        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1060        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1061        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1062        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1063        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1064        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1065        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1066        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1067        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1068        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1069        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1070        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1071        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1072        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1073        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1074        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1075        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1076        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1077        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1078        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1079        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1080        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1081        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1082        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1083        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1084        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1085        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1086        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1087        'ETOT=  ',1pE16.6,' (total)')
1088 #endif
1089       return
1090       end subroutine enerprint
1091 !-----------------------------------------------------------------------------
1092       subroutine elj(evdw)
1093 !
1094 ! This subroutine calculates the interaction energy of nonbonded side chains
1095 ! assuming the LJ potential of interaction.
1096 !
1097 !      implicit real*8 (a-h,o-z)
1098 !      include 'DIMENSIONS'
1099       real(kind=8),parameter :: accur=1.0d-10
1100 !      include 'COMMON.GEO'
1101 !      include 'COMMON.VAR'
1102 !      include 'COMMON.LOCAL'
1103 !      include 'COMMON.CHAIN'
1104 !      include 'COMMON.DERIV'
1105 !      include 'COMMON.INTERACT'
1106 !      include 'COMMON.TORSION'
1107 !      include 'COMMON.SBRIDGE'
1108 !      include 'COMMON.NAMES'
1109 !      include 'COMMON.IOUNITS'
1110 !      include 'COMMON.CONTACTS'
1111       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1112       integer :: num_conti
1113 !el local variables
1114       integer :: i,itypi,iint,j,itypi1,itypj,k
1115       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1116       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1117       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1118
1119 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1120       evdw=0.0D0
1121 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1122 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1123 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1124 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1125
1126       do i=iatsc_s,iatsc_e
1127         itypi=iabs(itype(i,1))
1128         if (itypi.eq.ntyp1) cycle
1129         itypi1=iabs(itype(i+1,1))
1130         xi=c(1,nres+i)
1131         yi=c(2,nres+i)
1132         zi=c(3,nres+i)
1133 ! Change 12/1/95
1134         num_conti=0
1135 !
1136 ! Calculate SC interaction energy.
1137 !
1138         do iint=1,nint_gr(i)
1139 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1140 !d   &                  'iend=',iend(i,iint)
1141           do j=istart(i,iint),iend(i,iint)
1142             itypj=iabs(itype(j,1))
1143             if (itypj.eq.ntyp1) cycle
1144             xj=c(1,nres+j)-xi
1145             yj=c(2,nres+j)-yi
1146             zj=c(3,nres+j)-zi
1147 ! Change 12/1/95 to calculate four-body interactions
1148             rij=xj*xj+yj*yj+zj*zj
1149             rrij=1.0D0/rij
1150 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1151             eps0ij=eps(itypi,itypj)
1152             fac=rrij**expon2
1153             e1=fac*fac*aa_aq(itypi,itypj)
1154             e2=fac*bb_aq(itypi,itypj)
1155             evdwij=e1+e2
1156 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1157 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1158 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1159 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1160 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1161 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1162             evdw=evdw+evdwij
1163 !
1164 ! Calculate the components of the gradient in DC and X
1165 !
1166             fac=-rrij*(e1+evdwij)
1167             gg(1)=xj*fac
1168             gg(2)=yj*fac
1169             gg(3)=zj*fac
1170             do k=1,3
1171               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1172               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1173               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1174               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1175             enddo
1176 !grad            do k=i,j-1
1177 !grad              do l=1,3
1178 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1179 !grad              enddo
1180 !grad            enddo
1181 !
1182 ! 12/1/95, revised on 5/20/97
1183 !
1184 ! Calculate the contact function. The ith column of the array JCONT will
1185 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1186 ! greater than I). The arrays FACONT and GACONT will contain the values of
1187 ! the contact function and its derivative.
1188 !
1189 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1190 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1191 ! Uncomment next line, if the correlation interactions are contact function only
1192             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1193               rij=dsqrt(rij)
1194               sigij=sigma(itypi,itypj)
1195               r0ij=rs0(itypi,itypj)
1196 !
1197 ! Check whether the SC's are not too far to make a contact.
1198 !
1199               rcut=1.5d0*r0ij
1200               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1201 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1202 !
1203               if (fcont.gt.0.0D0) then
1204 ! If the SC-SC distance if close to sigma, apply spline.
1205 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1206 !Adam &             fcont1,fprimcont1)
1207 !Adam           fcont1=1.0d0-fcont1
1208 !Adam           if (fcont1.gt.0.0d0) then
1209 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1210 !Adam             fcont=fcont*fcont1
1211 !Adam           endif
1212 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1213 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1214 !ga             do k=1,3
1215 !ga               gg(k)=gg(k)*eps0ij
1216 !ga             enddo
1217 !ga             eps0ij=-evdwij*eps0ij
1218 ! Uncomment for AL's type of SC correlation interactions.
1219 !adam           eps0ij=-evdwij
1220                 num_conti=num_conti+1
1221                 jcont(num_conti,i)=j
1222                 facont(num_conti,i)=fcont*eps0ij
1223                 fprimcont=eps0ij*fprimcont/rij
1224                 fcont=expon*fcont
1225 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1226 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1227 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1228 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1229                 gacont(1,num_conti,i)=-fprimcont*xj
1230                 gacont(2,num_conti,i)=-fprimcont*yj
1231                 gacont(3,num_conti,i)=-fprimcont*zj
1232 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1233 !d              write (iout,'(2i3,3f10.5)')
1234 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1235               endif
1236             endif
1237           enddo      ! j
1238         enddo        ! iint
1239 ! Change 12/1/95
1240         num_cont(i)=num_conti
1241       enddo          ! i
1242       do i=1,nct
1243         do j=1,3
1244           gvdwc(j,i)=expon*gvdwc(j,i)
1245           gvdwx(j,i)=expon*gvdwx(j,i)
1246         enddo
1247       enddo
1248 !******************************************************************************
1249 !
1250 !                              N O T E !!!
1251 !
1252 ! To save time, the factor of EXPON has been extracted from ALL components
1253 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1254 ! use!
1255 !
1256 !******************************************************************************
1257       return
1258       end subroutine elj
1259 !-----------------------------------------------------------------------------
1260       subroutine eljk(evdw)
1261 !
1262 ! This subroutine calculates the interaction energy of nonbonded side chains
1263 ! assuming the LJK potential of interaction.
1264 !
1265 !      implicit real*8 (a-h,o-z)
1266 !      include 'DIMENSIONS'
1267 !      include 'COMMON.GEO'
1268 !      include 'COMMON.VAR'
1269 !      include 'COMMON.LOCAL'
1270 !      include 'COMMON.CHAIN'
1271 !      include 'COMMON.DERIV'
1272 !      include 'COMMON.INTERACT'
1273 !      include 'COMMON.IOUNITS'
1274 !      include 'COMMON.NAMES'
1275       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1276       logical :: scheck
1277 !el local variables
1278       integer :: i,iint,j,itypi,itypi1,k,itypj
1279       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1280       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1281
1282 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1283       evdw=0.0D0
1284       do i=iatsc_s,iatsc_e
1285         itypi=iabs(itype(i,1))
1286         if (itypi.eq.ntyp1) cycle
1287         itypi1=iabs(itype(i+1,1))
1288         xi=c(1,nres+i)
1289         yi=c(2,nres+i)
1290         zi=c(3,nres+i)
1291 !
1292 ! Calculate SC interaction energy.
1293 !
1294         do iint=1,nint_gr(i)
1295           do j=istart(i,iint),iend(i,iint)
1296             itypj=iabs(itype(j,1))
1297             if (itypj.eq.ntyp1) cycle
1298             xj=c(1,nres+j)-xi
1299             yj=c(2,nres+j)-yi
1300             zj=c(3,nres+j)-zi
1301             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1302             fac_augm=rrij**expon
1303             e_augm=augm(itypi,itypj)*fac_augm
1304             r_inv_ij=dsqrt(rrij)
1305             rij=1.0D0/r_inv_ij
1306             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1307             fac=r_shift_inv**expon
1308             e1=fac*fac*aa_aq(itypi,itypj)
1309             e2=fac*bb_aq(itypi,itypj)
1310             evdwij=e_augm+e1+e2
1311 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1312 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1313 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1314 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1315 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1316 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1317 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1318             evdw=evdw+evdwij
1319 !
1320 ! Calculate the components of the gradient in DC and X
1321 !
1322             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1323             gg(1)=xj*fac
1324             gg(2)=yj*fac
1325             gg(3)=zj*fac
1326             do k=1,3
1327               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1328               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1329               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1330               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1331             enddo
1332 !grad            do k=i,j-1
1333 !grad              do l=1,3
1334 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1335 !grad              enddo
1336 !grad            enddo
1337           enddo      ! j
1338         enddo        ! iint
1339       enddo          ! i
1340       do i=1,nct
1341         do j=1,3
1342           gvdwc(j,i)=expon*gvdwc(j,i)
1343           gvdwx(j,i)=expon*gvdwx(j,i)
1344         enddo
1345       enddo
1346       return
1347       end subroutine eljk
1348 !-----------------------------------------------------------------------------
1349       subroutine ebp(evdw)
1350 !
1351 ! This subroutine calculates the interaction energy of nonbonded side chains
1352 ! assuming the Berne-Pechukas potential of interaction.
1353 !
1354       use comm_srutu
1355       use calc_data
1356 !      implicit real*8 (a-h,o-z)
1357 !      include 'DIMENSIONS'
1358 !      include 'COMMON.GEO'
1359 !      include 'COMMON.VAR'
1360 !      include 'COMMON.LOCAL'
1361 !      include 'COMMON.CHAIN'
1362 !      include 'COMMON.DERIV'
1363 !      include 'COMMON.NAMES'
1364 !      include 'COMMON.INTERACT'
1365 !      include 'COMMON.IOUNITS'
1366 !      include 'COMMON.CALC'
1367       use comm_srutu
1368 !el      integer :: icall
1369 !el      common /srutu/ icall
1370 !     double precision rrsave(maxdim)
1371       logical :: lprn
1372 !el local variables
1373       integer :: iint,itypi,itypi1,itypj
1374       real(kind=8) :: rrij,xi,yi,zi
1375       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1376
1377 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1378       evdw=0.0D0
1379 !     if (icall.eq.0) then
1380 !       lprn=.true.
1381 !     else
1382         lprn=.false.
1383 !     endif
1384 !el      ind=0
1385       do i=iatsc_s,iatsc_e
1386         itypi=iabs(itype(i,1))
1387         if (itypi.eq.ntyp1) cycle
1388         itypi1=iabs(itype(i+1,1))
1389         xi=c(1,nres+i)
1390         yi=c(2,nres+i)
1391         zi=c(3,nres+i)
1392         dxi=dc_norm(1,nres+i)
1393         dyi=dc_norm(2,nres+i)
1394         dzi=dc_norm(3,nres+i)
1395 !        dsci_inv=dsc_inv(itypi)
1396         dsci_inv=vbld_inv(i+nres)
1397 !
1398 ! Calculate SC interaction energy.
1399 !
1400         do iint=1,nint_gr(i)
1401           do j=istart(i,iint),iend(i,iint)
1402 !el            ind=ind+1
1403             itypj=iabs(itype(j,1))
1404             if (itypj.eq.ntyp1) cycle
1405 !            dscj_inv=dsc_inv(itypj)
1406             dscj_inv=vbld_inv(j+nres)
1407             chi1=chi(itypi,itypj)
1408             chi2=chi(itypj,itypi)
1409             chi12=chi1*chi2
1410             chip1=chip(itypi)
1411             chip2=chip(itypj)
1412             chip12=chip1*chip2
1413             alf1=alp(itypi)
1414             alf2=alp(itypj)
1415             alf12=0.5D0*(alf1+alf2)
1416 ! For diagnostics only!!!
1417 !           chi1=0.0D0
1418 !           chi2=0.0D0
1419 !           chi12=0.0D0
1420 !           chip1=0.0D0
1421 !           chip2=0.0D0
1422 !           chip12=0.0D0
1423 !           alf1=0.0D0
1424 !           alf2=0.0D0
1425 !           alf12=0.0D0
1426             xj=c(1,nres+j)-xi
1427             yj=c(2,nres+j)-yi
1428             zj=c(3,nres+j)-zi
1429             dxj=dc_norm(1,nres+j)
1430             dyj=dc_norm(2,nres+j)
1431             dzj=dc_norm(3,nres+j)
1432             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1433 !d          if (icall.eq.0) then
1434 !d            rrsave(ind)=rrij
1435 !d          else
1436 !d            rrij=rrsave(ind)
1437 !d          endif
1438             rij=dsqrt(rrij)
1439 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1440             call sc_angular
1441 ! Calculate whole angle-dependent part of epsilon and contributions
1442 ! to its derivatives
1443             fac=(rrij*sigsq)**expon2
1444             e1=fac*fac*aa_aq(itypi,itypj)
1445             e2=fac*bb_aq(itypi,itypj)
1446             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1447             eps2der=evdwij*eps3rt
1448             eps3der=evdwij*eps2rt
1449             evdwij=evdwij*eps2rt*eps3rt
1450             evdw=evdw+evdwij
1451             if (lprn) then
1452             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1453             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1454 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1455 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1456 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1457 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1458 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1459 !d     &        evdwij
1460             endif
1461 ! Calculate gradient components.
1462             e1=e1*eps1*eps2rt**2*eps3rt**2
1463             fac=-expon*(e1+evdwij)
1464             sigder=fac/sigsq
1465             fac=rrij*fac
1466 ! Calculate radial part of the gradient
1467             gg(1)=xj*fac
1468             gg(2)=yj*fac
1469             gg(3)=zj*fac
1470 ! Calculate the angular part of the gradient and sum add the contributions
1471 ! to the appropriate components of the Cartesian gradient.
1472             call sc_grad
1473           enddo      ! j
1474         enddo        ! iint
1475       enddo          ! i
1476 !     stop
1477       return
1478       end subroutine ebp
1479 !-----------------------------------------------------------------------------
1480       subroutine egb(evdw)
1481 !
1482 ! This subroutine calculates the interaction energy of nonbonded side chains
1483 ! assuming the Gay-Berne potential of interaction.
1484 !
1485       use calc_data
1486 !      implicit real*8 (a-h,o-z)
1487 !      include 'DIMENSIONS'
1488 !      include 'COMMON.GEO'
1489 !      include 'COMMON.VAR'
1490 !      include 'COMMON.LOCAL'
1491 !      include 'COMMON.CHAIN'
1492 !      include 'COMMON.DERIV'
1493 !      include 'COMMON.NAMES'
1494 !      include 'COMMON.INTERACT'
1495 !      include 'COMMON.IOUNITS'
1496 !      include 'COMMON.CALC'
1497 !      include 'COMMON.CONTROL'
1498 !      include 'COMMON.SBRIDGE'
1499       logical :: lprn
1500 !el local variables
1501       integer :: iint,itypi,itypi1,itypj,subchap
1502       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1503       real(kind=8) :: evdw,sig0ij
1504       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1505                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1506                     sslipi,sslipj,faclip
1507       integer :: ii
1508       real(kind=8) :: fracinbuf
1509
1510 !cccc      energy_dec=.false.
1511 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1512       evdw=0.0D0
1513       lprn=.false.
1514 !     if (icall.eq.0) lprn=.false.
1515 !el      ind=0
1516       do i=iatsc_s,iatsc_e
1517 !C        print *,"I am in EVDW",i
1518         itypi=iabs(itype(i,1))
1519 !        if (i.ne.47) cycle
1520         if (itypi.eq.ntyp1) cycle
1521         itypi1=iabs(itype(i+1,1))
1522         xi=c(1,nres+i)
1523         yi=c(2,nres+i)
1524         zi=c(3,nres+i)
1525           xi=dmod(xi,boxxsize)
1526           if (xi.lt.0) xi=xi+boxxsize
1527           yi=dmod(yi,boxysize)
1528           if (yi.lt.0) yi=yi+boxysize
1529           zi=dmod(zi,boxzsize)
1530           if (zi.lt.0) zi=zi+boxzsize
1531
1532        if ((zi.gt.bordlipbot)  &
1533         .and.(zi.lt.bordliptop)) then
1534 !C the energy transfer exist
1535         if (zi.lt.buflipbot) then
1536 !C what fraction I am in
1537          fracinbuf=1.0d0-  &
1538               ((zi-bordlipbot)/lipbufthick)
1539 !C lipbufthick is thickenes of lipid buffore
1540          sslipi=sscalelip(fracinbuf)
1541          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1542         elseif (zi.gt.bufliptop) then
1543          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1544          sslipi=sscalelip(fracinbuf)
1545          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1546         else
1547          sslipi=1.0d0
1548          ssgradlipi=0.0
1549         endif
1550        else
1551          sslipi=0.0d0
1552          ssgradlipi=0.0
1553        endif
1554 !       print *, sslipi,ssgradlipi
1555         dxi=dc_norm(1,nres+i)
1556         dyi=dc_norm(2,nres+i)
1557         dzi=dc_norm(3,nres+i)
1558 !        dsci_inv=dsc_inv(itypi)
1559         dsci_inv=vbld_inv(i+nres)
1560 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1561 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1562 !
1563 ! Calculate SC interaction energy.
1564 !
1565         do iint=1,nint_gr(i)
1566           do j=istart(i,iint),iend(i,iint)
1567             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1568               call dyn_ssbond_ene(i,j,evdwij)
1569               evdw=evdw+evdwij
1570               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1571                               'evdw',i,j,evdwij,' ss'
1572 !              if (energy_dec) write (iout,*) &
1573 !                              'evdw',i,j,evdwij,' ss'
1574              do k=j+1,iend(i,iint)
1575 !C search over all next residues
1576               if (dyn_ss_mask(k)) then
1577 !C check if they are cysteins
1578 !C              write(iout,*) 'k=',k
1579
1580 !c              write(iout,*) "PRZED TRI", evdwij
1581 !               evdwij_przed_tri=evdwij
1582               call triple_ssbond_ene(i,j,k,evdwij)
1583 !c               if(evdwij_przed_tri.ne.evdwij) then
1584 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1585 !c               endif
1586
1587 !c              write(iout,*) "PO TRI", evdwij
1588 !C call the energy function that removes the artifical triple disulfide
1589 !C bond the soubroutine is located in ssMD.F
1590               evdw=evdw+evdwij
1591               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1592                             'evdw',i,j,evdwij,'tss'
1593               endif!dyn_ss_mask(k)
1594              enddo! k
1595             ELSE
1596 !el            ind=ind+1
1597             itypj=iabs(itype(j,1))
1598             if (itypj.eq.ntyp1) cycle
1599 !             if (j.ne.78) cycle
1600 !            dscj_inv=dsc_inv(itypj)
1601             dscj_inv=vbld_inv(j+nres)
1602 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1603 !              1.0d0/vbld(j+nres) !d
1604 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1605             sig0ij=sigma(itypi,itypj)
1606             chi1=chi(itypi,itypj)
1607             chi2=chi(itypj,itypi)
1608             chi12=chi1*chi2
1609             chip1=chip(itypi)
1610             chip2=chip(itypj)
1611             chip12=chip1*chip2
1612             alf1=alp(itypi)
1613             alf2=alp(itypj)
1614             alf12=0.5D0*(alf1+alf2)
1615 ! For diagnostics only!!!
1616 !           chi1=0.0D0
1617 !           chi2=0.0D0
1618 !           chi12=0.0D0
1619 !           chip1=0.0D0
1620 !           chip2=0.0D0
1621 !           chip12=0.0D0
1622 !           alf1=0.0D0
1623 !           alf2=0.0D0
1624 !           alf12=0.0D0
1625            xj=c(1,nres+j)
1626            yj=c(2,nres+j)
1627            zj=c(3,nres+j)
1628           xj=dmod(xj,boxxsize)
1629           if (xj.lt.0) xj=xj+boxxsize
1630           yj=dmod(yj,boxysize)
1631           if (yj.lt.0) yj=yj+boxysize
1632           zj=dmod(zj,boxzsize)
1633           if (zj.lt.0) zj=zj+boxzsize
1634 !          print *,"tu",xi,yi,zi,xj,yj,zj
1635 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1636 ! this fragment set correct epsilon for lipid phase
1637        if ((zj.gt.bordlipbot)  &
1638        .and.(zj.lt.bordliptop)) then
1639 !C the energy transfer exist
1640         if (zj.lt.buflipbot) then
1641 !C what fraction I am in
1642          fracinbuf=1.0d0-     &
1643              ((zj-bordlipbot)/lipbufthick)
1644 !C lipbufthick is thickenes of lipid buffore
1645          sslipj=sscalelip(fracinbuf)
1646          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1647         elseif (zj.gt.bufliptop) then
1648          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1649          sslipj=sscalelip(fracinbuf)
1650          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1651         else
1652          sslipj=1.0d0
1653          ssgradlipj=0.0
1654         endif
1655        else
1656          sslipj=0.0d0
1657          ssgradlipj=0.0
1658        endif
1659       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1660        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1661       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1662        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1663 !------------------------------------------------
1664       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1665       xj_safe=xj
1666       yj_safe=yj
1667       zj_safe=zj
1668       subchap=0
1669       do xshift=-1,1
1670       do yshift=-1,1
1671       do zshift=-1,1
1672           xj=xj_safe+xshift*boxxsize
1673           yj=yj_safe+yshift*boxysize
1674           zj=zj_safe+zshift*boxzsize
1675           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1676           if(dist_temp.lt.dist_init) then
1677             dist_init=dist_temp
1678             xj_temp=xj
1679             yj_temp=yj
1680             zj_temp=zj
1681             subchap=1
1682           endif
1683        enddo
1684        enddo
1685        enddo
1686        if (subchap.eq.1) then
1687           xj=xj_temp-xi
1688           yj=yj_temp-yi
1689           zj=zj_temp-zi
1690        else
1691           xj=xj_safe-xi
1692           yj=yj_safe-yi
1693           zj=zj_safe-zi
1694        endif
1695             dxj=dc_norm(1,nres+j)
1696             dyj=dc_norm(2,nres+j)
1697             dzj=dc_norm(3,nres+j)
1698 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1699 !            write (iout,*) "j",j," dc_norm",& !d
1700 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1701 !          write(iout,*)"rrij ",rrij
1702 !          write(iout,*)"xj yj zj ", xj, yj, zj
1703 !          write(iout,*)"xi yi zi ", xi, yi, zi
1704 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1705             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1706             rij=dsqrt(rrij)
1707             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1708             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1709 !            print *,sss_ele_cut,sss_ele_grad,&
1710 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1711             if (sss_ele_cut.le.0.0) cycle
1712 ! Calculate angle-dependent terms of energy and contributions to their
1713 ! derivatives.
1714             call sc_angular
1715             sigsq=1.0D0/sigsq
1716             sig=sig0ij*dsqrt(sigsq)
1717             rij_shift=1.0D0/rij-sig+sig0ij
1718 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1719 !            "sig0ij",sig0ij
1720 ! for diagnostics; uncomment
1721 !            rij_shift=1.2*sig0ij
1722 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1723             if (rij_shift.le.0.0D0) then
1724               evdw=1.0D20
1725 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1726 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1727 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1728               return
1729             endif
1730             sigder=-sig*sigsq
1731 !---------------------------------------------------------------
1732             rij_shift=1.0D0/rij_shift
1733             fac=rij_shift**expon
1734             faclip=fac
1735             e1=fac*fac*aa!(itypi,itypj)
1736             e2=fac*bb!(itypi,itypj)
1737             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1738             eps2der=evdwij*eps3rt
1739             eps3der=evdwij*eps2rt
1740 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1741 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1742 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1743             evdwij=evdwij*eps2rt*eps3rt
1744             evdw=evdw+evdwij*sss_ele_cut
1745             if (lprn) then
1746             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1747             epsi=bb**2/aa!(itypi,itypj)
1748             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1749               restyp(itypi,1),i,restyp(itypj,1),j, &
1750               epsi,sigm,chi1,chi2,chip1,chip2, &
1751               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1752               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1753               evdwij
1754             endif
1755
1756             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1757                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1758 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1759 !            if (energy_dec) write (iout,*) &
1760 !                             'evdw',i,j,evdwij
1761 !                       print *,"ZALAMKA", evdw
1762
1763 ! Calculate gradient components.
1764             e1=e1*eps1*eps2rt**2*eps3rt**2
1765             fac=-expon*(e1+evdwij)*rij_shift
1766             sigder=fac*sigder
1767             fac=rij*fac
1768 !            print *,'before fac',fac,rij,evdwij
1769             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1770             /sigma(itypi,itypj)*rij
1771 !            print *,'grad part scale',fac,   &
1772 !             evdwij*sss_ele_grad/sss_ele_cut &
1773 !            /sigma(itypi,itypj)*rij
1774 !            fac=0.0d0
1775 ! Calculate the radial part of the gradient
1776             gg(1)=xj*fac
1777             gg(2)=yj*fac
1778             gg(3)=zj*fac
1779 !C Calculate the radial part of the gradient
1780             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1781        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1782         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1783        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1784             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1785             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1786
1787 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1788 ! Calculate angular part of the gradient.
1789             call sc_grad
1790             ENDIF    ! dyn_ss
1791           enddo      ! j
1792         enddo        ! iint
1793       enddo          ! i
1794 !       print *,"ZALAMKA", evdw
1795 !      write (iout,*) "Number of loop steps in EGB:",ind
1796 !ccc      energy_dec=.false.
1797       return
1798       end subroutine egb
1799 !-----------------------------------------------------------------------------
1800       subroutine egbv(evdw)
1801 !
1802 ! This subroutine calculates the interaction energy of nonbonded side chains
1803 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1804 !
1805       use comm_srutu
1806       use calc_data
1807 !      implicit real*8 (a-h,o-z)
1808 !      include 'DIMENSIONS'
1809 !      include 'COMMON.GEO'
1810 !      include 'COMMON.VAR'
1811 !      include 'COMMON.LOCAL'
1812 !      include 'COMMON.CHAIN'
1813 !      include 'COMMON.DERIV'
1814 !      include 'COMMON.NAMES'
1815 !      include 'COMMON.INTERACT'
1816 !      include 'COMMON.IOUNITS'
1817 !      include 'COMMON.CALC'
1818       use comm_srutu
1819 !el      integer :: icall
1820 !el      common /srutu/ icall
1821       logical :: lprn
1822 !el local variables
1823       integer :: iint,itypi,itypi1,itypj
1824       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1825       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1826
1827 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1828       evdw=0.0D0
1829       lprn=.false.
1830 !     if (icall.eq.0) lprn=.true.
1831 !el      ind=0
1832       do i=iatsc_s,iatsc_e
1833         itypi=iabs(itype(i,1))
1834         if (itypi.eq.ntyp1) cycle
1835         itypi1=iabs(itype(i+1,1))
1836         xi=c(1,nres+i)
1837         yi=c(2,nres+i)
1838         zi=c(3,nres+i)
1839         dxi=dc_norm(1,nres+i)
1840         dyi=dc_norm(2,nres+i)
1841         dzi=dc_norm(3,nres+i)
1842 !        dsci_inv=dsc_inv(itypi)
1843         dsci_inv=vbld_inv(i+nres)
1844 !
1845 ! Calculate SC interaction energy.
1846 !
1847         do iint=1,nint_gr(i)
1848           do j=istart(i,iint),iend(i,iint)
1849 !el            ind=ind+1
1850             itypj=iabs(itype(j,1))
1851             if (itypj.eq.ntyp1) cycle
1852 !            dscj_inv=dsc_inv(itypj)
1853             dscj_inv=vbld_inv(j+nres)
1854             sig0ij=sigma(itypi,itypj)
1855             r0ij=r0(itypi,itypj)
1856             chi1=chi(itypi,itypj)
1857             chi2=chi(itypj,itypi)
1858             chi12=chi1*chi2
1859             chip1=chip(itypi)
1860             chip2=chip(itypj)
1861             chip12=chip1*chip2
1862             alf1=alp(itypi)
1863             alf2=alp(itypj)
1864             alf12=0.5D0*(alf1+alf2)
1865 ! For diagnostics only!!!
1866 !           chi1=0.0D0
1867 !           chi2=0.0D0
1868 !           chi12=0.0D0
1869 !           chip1=0.0D0
1870 !           chip2=0.0D0
1871 !           chip12=0.0D0
1872 !           alf1=0.0D0
1873 !           alf2=0.0D0
1874 !           alf12=0.0D0
1875             xj=c(1,nres+j)-xi
1876             yj=c(2,nres+j)-yi
1877             zj=c(3,nres+j)-zi
1878             dxj=dc_norm(1,nres+j)
1879             dyj=dc_norm(2,nres+j)
1880             dzj=dc_norm(3,nres+j)
1881             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1882             rij=dsqrt(rrij)
1883 ! Calculate angle-dependent terms of energy and contributions to their
1884 ! derivatives.
1885             call sc_angular
1886             sigsq=1.0D0/sigsq
1887             sig=sig0ij*dsqrt(sigsq)
1888             rij_shift=1.0D0/rij-sig+r0ij
1889 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1890             if (rij_shift.le.0.0D0) then
1891               evdw=1.0D20
1892               return
1893             endif
1894             sigder=-sig*sigsq
1895 !---------------------------------------------------------------
1896             rij_shift=1.0D0/rij_shift
1897             fac=rij_shift**expon
1898             e1=fac*fac*aa_aq(itypi,itypj)
1899             e2=fac*bb_aq(itypi,itypj)
1900             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1901             eps2der=evdwij*eps3rt
1902             eps3der=evdwij*eps2rt
1903             fac_augm=rrij**expon
1904             e_augm=augm(itypi,itypj)*fac_augm
1905             evdwij=evdwij*eps2rt*eps3rt
1906             evdw=evdw+evdwij+e_augm
1907             if (lprn) then
1908             sigm=dabs(aa_aq(itypi,itypj)/&
1909             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1910             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1911             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1912               restyp(itypi,1),i,restyp(itypj,1),j,&
1913               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1914               chi1,chi2,chip1,chip2,&
1915               eps1,eps2rt**2,eps3rt**2,&
1916               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1917               evdwij+e_augm
1918             endif
1919 ! Calculate gradient components.
1920             e1=e1*eps1*eps2rt**2*eps3rt**2
1921             fac=-expon*(e1+evdwij)*rij_shift
1922             sigder=fac*sigder
1923             fac=rij*fac-2*expon*rrij*e_augm
1924 ! Calculate the radial part of the gradient
1925             gg(1)=xj*fac
1926             gg(2)=yj*fac
1927             gg(3)=zj*fac
1928 ! Calculate angular part of the gradient.
1929             call sc_grad
1930           enddo      ! j
1931         enddo        ! iint
1932       enddo          ! i
1933       end subroutine egbv
1934 !-----------------------------------------------------------------------------
1935 !el      subroutine sc_angular in module geometry
1936 !-----------------------------------------------------------------------------
1937       subroutine e_softsphere(evdw)
1938 !
1939 ! This subroutine calculates the interaction energy of nonbonded side chains
1940 ! assuming the LJ potential of interaction.
1941 !
1942 !      implicit real*8 (a-h,o-z)
1943 !      include 'DIMENSIONS'
1944       real(kind=8),parameter :: accur=1.0d-10
1945 !      include 'COMMON.GEO'
1946 !      include 'COMMON.VAR'
1947 !      include 'COMMON.LOCAL'
1948 !      include 'COMMON.CHAIN'
1949 !      include 'COMMON.DERIV'
1950 !      include 'COMMON.INTERACT'
1951 !      include 'COMMON.TORSION'
1952 !      include 'COMMON.SBRIDGE'
1953 !      include 'COMMON.NAMES'
1954 !      include 'COMMON.IOUNITS'
1955 !      include 'COMMON.CONTACTS'
1956       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1957 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1958 !el local variables
1959       integer :: i,iint,j,itypi,itypi1,itypj,k
1960       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1961       real(kind=8) :: fac
1962
1963       evdw=0.0D0
1964       do i=iatsc_s,iatsc_e
1965         itypi=iabs(itype(i,1))
1966         if (itypi.eq.ntyp1) cycle
1967         itypi1=iabs(itype(i+1,1))
1968         xi=c(1,nres+i)
1969         yi=c(2,nres+i)
1970         zi=c(3,nres+i)
1971 !
1972 ! Calculate SC interaction energy.
1973 !
1974         do iint=1,nint_gr(i)
1975 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1976 !d   &                  'iend=',iend(i,iint)
1977           do j=istart(i,iint),iend(i,iint)
1978             itypj=iabs(itype(j,1))
1979             if (itypj.eq.ntyp1) cycle
1980             xj=c(1,nres+j)-xi
1981             yj=c(2,nres+j)-yi
1982             zj=c(3,nres+j)-zi
1983             rij=xj*xj+yj*yj+zj*zj
1984 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1985             r0ij=r0(itypi,itypj)
1986             r0ijsq=r0ij*r0ij
1987 !            print *,i,j,r0ij,dsqrt(rij)
1988             if (rij.lt.r0ijsq) then
1989               evdwij=0.25d0*(rij-r0ijsq)**2
1990               fac=rij-r0ijsq
1991             else
1992               evdwij=0.0d0
1993               fac=0.0d0
1994             endif
1995             evdw=evdw+evdwij
1996 !
1997 ! Calculate the components of the gradient in DC and X
1998 !
1999             gg(1)=xj*fac
2000             gg(2)=yj*fac
2001             gg(3)=zj*fac
2002             do k=1,3
2003               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2004               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2005               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2006               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2007             enddo
2008 !grad            do k=i,j-1
2009 !grad              do l=1,3
2010 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2011 !grad              enddo
2012 !grad            enddo
2013           enddo ! j
2014         enddo ! iint
2015       enddo ! i
2016       return
2017       end subroutine e_softsphere
2018 !-----------------------------------------------------------------------------
2019       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2020 !
2021 ! Soft-sphere potential of p-p interaction
2022 !
2023 !      implicit real*8 (a-h,o-z)
2024 !      include 'DIMENSIONS'
2025 !      include 'COMMON.CONTROL'
2026 !      include 'COMMON.IOUNITS'
2027 !      include 'COMMON.GEO'
2028 !      include 'COMMON.VAR'
2029 !      include 'COMMON.LOCAL'
2030 !      include 'COMMON.CHAIN'
2031 !      include 'COMMON.DERIV'
2032 !      include 'COMMON.INTERACT'
2033 !      include 'COMMON.CONTACTS'
2034 !      include 'COMMON.TORSION'
2035 !      include 'COMMON.VECTORS'
2036 !      include 'COMMON.FFIELD'
2037       real(kind=8),dimension(3) :: ggg
2038 !d      write(iout,*) 'In EELEC_soft_sphere'
2039 !el local variables
2040       integer :: i,j,k,num_conti,iteli,itelj
2041       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2042       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2043       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2044
2045       ees=0.0D0
2046       evdw1=0.0D0
2047       eel_loc=0.0d0
2048       eello_turn3=0.0d0
2049       eello_turn4=0.0d0
2050 !el      ind=0
2051       do i=iatel_s,iatel_e
2052         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2053         dxi=dc(1,i)
2054         dyi=dc(2,i)
2055         dzi=dc(3,i)
2056         xmedi=c(1,i)+0.5d0*dxi
2057         ymedi=c(2,i)+0.5d0*dyi
2058         zmedi=c(3,i)+0.5d0*dzi
2059         num_conti=0
2060 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2061         do j=ielstart(i),ielend(i)
2062           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2063 !el          ind=ind+1
2064           iteli=itel(i)
2065           itelj=itel(j)
2066           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2067           r0ij=rpp(iteli,itelj)
2068           r0ijsq=r0ij*r0ij
2069           dxj=dc(1,j)
2070           dyj=dc(2,j)
2071           dzj=dc(3,j)
2072           xj=c(1,j)+0.5D0*dxj-xmedi
2073           yj=c(2,j)+0.5D0*dyj-ymedi
2074           zj=c(3,j)+0.5D0*dzj-zmedi
2075           rij=xj*xj+yj*yj+zj*zj
2076           if (rij.lt.r0ijsq) then
2077             evdw1ij=0.25d0*(rij-r0ijsq)**2
2078             fac=rij-r0ijsq
2079           else
2080             evdw1ij=0.0d0
2081             fac=0.0d0
2082           endif
2083           evdw1=evdw1+evdw1ij
2084 !
2085 ! Calculate contributions to the Cartesian gradient.
2086 !
2087           ggg(1)=fac*xj
2088           ggg(2)=fac*yj
2089           ggg(3)=fac*zj
2090           do k=1,3
2091             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2092             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2093           enddo
2094 !
2095 ! Loop over residues i+1 thru j-1.
2096 !
2097 !grad          do k=i+1,j-1
2098 !grad            do l=1,3
2099 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2100 !grad            enddo
2101 !grad          enddo
2102         enddo ! j
2103       enddo   ! i
2104 !grad      do i=nnt,nct-1
2105 !grad        do k=1,3
2106 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2107 !grad        enddo
2108 !grad        do j=i+1,nct-1
2109 !grad          do k=1,3
2110 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2111 !grad          enddo
2112 !grad        enddo
2113 !grad      enddo
2114       return
2115       end subroutine eelec_soft_sphere
2116 !-----------------------------------------------------------------------------
2117       subroutine vec_and_deriv
2118 !      implicit real*8 (a-h,o-z)
2119 !      include 'DIMENSIONS'
2120 #ifdef MPI
2121       include 'mpif.h'
2122 #endif
2123 !      include 'COMMON.IOUNITS'
2124 !      include 'COMMON.GEO'
2125 !      include 'COMMON.VAR'
2126 !      include 'COMMON.LOCAL'
2127 !      include 'COMMON.CHAIN'
2128 !      include 'COMMON.VECTORS'
2129 !      include 'COMMON.SETUP'
2130 !      include 'COMMON.TIME1'
2131       real(kind=8),dimension(3,3,2) :: uyder,uzder
2132       real(kind=8),dimension(2) :: vbld_inv_temp
2133 ! Compute the local reference systems. For reference system (i), the
2134 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2135 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2136 !el local variables
2137       integer :: i,j,k,l
2138       real(kind=8) :: facy,fac,costh
2139
2140 #ifdef PARVEC
2141       do i=ivec_start,ivec_end
2142 #else
2143       do i=1,nres-1
2144 #endif
2145           if (i.eq.nres-1) then
2146 ! Case of the last full residue
2147 ! Compute the Z-axis
2148             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2149             costh=dcos(pi-theta(nres))
2150             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2151             do k=1,3
2152               uz(k,i)=fac*uz(k,i)
2153             enddo
2154 ! Compute the derivatives of uz
2155             uzder(1,1,1)= 0.0d0
2156             uzder(2,1,1)=-dc_norm(3,i-1)
2157             uzder(3,1,1)= dc_norm(2,i-1)
2158             uzder(1,2,1)= dc_norm(3,i-1)
2159             uzder(2,2,1)= 0.0d0
2160             uzder(3,2,1)=-dc_norm(1,i-1)
2161             uzder(1,3,1)=-dc_norm(2,i-1)
2162             uzder(2,3,1)= dc_norm(1,i-1)
2163             uzder(3,3,1)= 0.0d0
2164             uzder(1,1,2)= 0.0d0
2165             uzder(2,1,2)= dc_norm(3,i)
2166             uzder(3,1,2)=-dc_norm(2,i)
2167             uzder(1,2,2)=-dc_norm(3,i)
2168             uzder(2,2,2)= 0.0d0
2169             uzder(3,2,2)= dc_norm(1,i)
2170             uzder(1,3,2)= dc_norm(2,i)
2171             uzder(2,3,2)=-dc_norm(1,i)
2172             uzder(3,3,2)= 0.0d0
2173 ! Compute the Y-axis
2174             facy=fac
2175             do k=1,3
2176               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2177             enddo
2178 ! Compute the derivatives of uy
2179             do j=1,3
2180               do k=1,3
2181                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2182                               -dc_norm(k,i)*dc_norm(j,i-1)
2183                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2184               enddo
2185               uyder(j,j,1)=uyder(j,j,1)-costh
2186               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2187             enddo
2188             do j=1,2
2189               do k=1,3
2190                 do l=1,3
2191                   uygrad(l,k,j,i)=uyder(l,k,j)
2192                   uzgrad(l,k,j,i)=uzder(l,k,j)
2193                 enddo
2194               enddo
2195             enddo
2196             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2197             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2198             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2199             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2200           else
2201 ! Other residues
2202 ! Compute the Z-axis
2203             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2204             costh=dcos(pi-theta(i+2))
2205             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2206             do k=1,3
2207               uz(k,i)=fac*uz(k,i)
2208             enddo
2209 ! Compute the derivatives of uz
2210             uzder(1,1,1)= 0.0d0
2211             uzder(2,1,1)=-dc_norm(3,i+1)
2212             uzder(3,1,1)= dc_norm(2,i+1)
2213             uzder(1,2,1)= dc_norm(3,i+1)
2214             uzder(2,2,1)= 0.0d0
2215             uzder(3,2,1)=-dc_norm(1,i+1)
2216             uzder(1,3,1)=-dc_norm(2,i+1)
2217             uzder(2,3,1)= dc_norm(1,i+1)
2218             uzder(3,3,1)= 0.0d0
2219             uzder(1,1,2)= 0.0d0
2220             uzder(2,1,2)= dc_norm(3,i)
2221             uzder(3,1,2)=-dc_norm(2,i)
2222             uzder(1,2,2)=-dc_norm(3,i)
2223             uzder(2,2,2)= 0.0d0
2224             uzder(3,2,2)= dc_norm(1,i)
2225             uzder(1,3,2)= dc_norm(2,i)
2226             uzder(2,3,2)=-dc_norm(1,i)
2227             uzder(3,3,2)= 0.0d0
2228 ! Compute the Y-axis
2229             facy=fac
2230             do k=1,3
2231               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2232             enddo
2233 ! Compute the derivatives of uy
2234             do j=1,3
2235               do k=1,3
2236                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2237                               -dc_norm(k,i)*dc_norm(j,i+1)
2238                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2239               enddo
2240               uyder(j,j,1)=uyder(j,j,1)-costh
2241               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2242             enddo
2243             do j=1,2
2244               do k=1,3
2245                 do l=1,3
2246                   uygrad(l,k,j,i)=uyder(l,k,j)
2247                   uzgrad(l,k,j,i)=uzder(l,k,j)
2248                 enddo
2249               enddo
2250             enddo
2251             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2252             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2253             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2254             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2255           endif
2256       enddo
2257       do i=1,nres-1
2258         vbld_inv_temp(1)=vbld_inv(i+1)
2259         if (i.lt.nres-1) then
2260           vbld_inv_temp(2)=vbld_inv(i+2)
2261           else
2262           vbld_inv_temp(2)=vbld_inv(i)
2263           endif
2264         do j=1,2
2265           do k=1,3
2266             do l=1,3
2267               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2268               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2269             enddo
2270           enddo
2271         enddo
2272       enddo
2273 #if defined(PARVEC) && defined(MPI)
2274       if (nfgtasks1.gt.1) then
2275         time00=MPI_Wtime()
2276 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2277 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2278 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2279         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2280          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2281          FG_COMM1,IERR)
2282         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2283          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2284          FG_COMM1,IERR)
2285         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2286          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2287          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2288         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2289          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2290          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2291         time_gather=time_gather+MPI_Wtime()-time00
2292       endif
2293 !      if (fg_rank.eq.0) then
2294 !        write (iout,*) "Arrays UY and UZ"
2295 !        do i=1,nres-1
2296 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2297 !     &     (uz(k,i),k=1,3)
2298 !        enddo
2299 !      endif
2300 #endif
2301       return
2302       end subroutine vec_and_deriv
2303 !-----------------------------------------------------------------------------
2304       subroutine check_vecgrad
2305 !      implicit real*8 (a-h,o-z)
2306 !      include 'DIMENSIONS'
2307 !      include 'COMMON.IOUNITS'
2308 !      include 'COMMON.GEO'
2309 !      include 'COMMON.VAR'
2310 !      include 'COMMON.LOCAL'
2311 !      include 'COMMON.CHAIN'
2312 !      include 'COMMON.VECTORS'
2313       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2314       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2315       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2316       real(kind=8),dimension(3) :: erij
2317       real(kind=8) :: delta=1.0d-7
2318 !el local variables
2319       integer :: i,j,k,l
2320
2321       call vec_and_deriv
2322 !d      do i=1,nres
2323 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2324 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2325 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2326 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2327 !d     &     (dc_norm(if90,i),if90=1,3)
2328 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2329 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2330 !d          write(iout,'(a)')
2331 !d      enddo
2332       do i=1,nres
2333         do j=1,2
2334           do k=1,3
2335             do l=1,3
2336               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2337               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2338             enddo
2339           enddo
2340         enddo
2341       enddo
2342       call vec_and_deriv
2343       do i=1,nres
2344         do j=1,3
2345           uyt(j,i)=uy(j,i)
2346           uzt(j,i)=uz(j,i)
2347         enddo
2348       enddo
2349       do i=1,nres
2350 !d        write (iout,*) 'i=',i
2351         do k=1,3
2352           erij(k)=dc_norm(k,i)
2353         enddo
2354         do j=1,3
2355           do k=1,3
2356             dc_norm(k,i)=erij(k)
2357           enddo
2358           dc_norm(j,i)=dc_norm(j,i)+delta
2359 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2360 !          do k=1,3
2361 !            dc_norm(k,i)=dc_norm(k,i)/fac
2362 !          enddo
2363 !          write (iout,*) (dc_norm(k,i),k=1,3)
2364 !          write (iout,*) (erij(k),k=1,3)
2365           call vec_and_deriv
2366           do k=1,3
2367             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2368             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2369             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2370             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2371           enddo
2372 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2373 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2374 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2375         enddo
2376         do k=1,3
2377           dc_norm(k,i)=erij(k)
2378         enddo
2379 !d        do k=1,3
2380 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2381 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2382 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2383 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2384 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2385 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2386 !d          write (iout,'(a)')
2387 !d        enddo
2388       enddo
2389       return
2390       end subroutine check_vecgrad
2391 !-----------------------------------------------------------------------------
2392       subroutine set_matrices
2393 !      implicit real*8 (a-h,o-z)
2394 !      include 'DIMENSIONS'
2395 #ifdef MPI
2396       include "mpif.h"
2397 !      include "COMMON.SETUP"
2398       integer :: IERR
2399       integer :: status(MPI_STATUS_SIZE)
2400 #endif
2401 !      include 'COMMON.IOUNITS'
2402 !      include 'COMMON.GEO'
2403 !      include 'COMMON.VAR'
2404 !      include 'COMMON.LOCAL'
2405 !      include 'COMMON.CHAIN'
2406 !      include 'COMMON.DERIV'
2407 !      include 'COMMON.INTERACT'
2408 !      include 'COMMON.CONTACTS'
2409 !      include 'COMMON.TORSION'
2410 !      include 'COMMON.VECTORS'
2411 !      include 'COMMON.FFIELD'
2412       real(kind=8) :: auxvec(2),auxmat(2,2)
2413       integer :: i,iti1,iti,k,l
2414       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2415 !       print *,"in set matrices"
2416 !
2417 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2418 ! to calculate the el-loc multibody terms of various order.
2419 !
2420 !AL el      mu=0.0d0
2421 #ifdef PARMAT
2422       do i=ivec_start+2,ivec_end+2
2423 #else
2424       do i=3,nres+1
2425 #endif
2426 !      print *,i,"i"
2427         if (i .lt. nres+1) then
2428           sin1=dsin(phi(i))
2429           cos1=dcos(phi(i))
2430           sintab(i-2)=sin1
2431           costab(i-2)=cos1
2432           obrot(1,i-2)=cos1
2433           obrot(2,i-2)=sin1
2434           sin2=dsin(2*phi(i))
2435           cos2=dcos(2*phi(i))
2436           sintab2(i-2)=sin2
2437           costab2(i-2)=cos2
2438           obrot2(1,i-2)=cos2
2439           obrot2(2,i-2)=sin2
2440           Ug(1,1,i-2)=-cos1
2441           Ug(1,2,i-2)=-sin1
2442           Ug(2,1,i-2)=-sin1
2443           Ug(2,2,i-2)= cos1
2444           Ug2(1,1,i-2)=-cos2
2445           Ug2(1,2,i-2)=-sin2
2446           Ug2(2,1,i-2)=-sin2
2447           Ug2(2,2,i-2)= cos2
2448         else
2449           costab(i-2)=1.0d0
2450           sintab(i-2)=0.0d0
2451           obrot(1,i-2)=1.0d0
2452           obrot(2,i-2)=0.0d0
2453           obrot2(1,i-2)=0.0d0
2454           obrot2(2,i-2)=0.0d0
2455           Ug(1,1,i-2)=1.0d0
2456           Ug(1,2,i-2)=0.0d0
2457           Ug(2,1,i-2)=0.0d0
2458           Ug(2,2,i-2)=1.0d0
2459           Ug2(1,1,i-2)=0.0d0
2460           Ug2(1,2,i-2)=0.0d0
2461           Ug2(2,1,i-2)=0.0d0
2462           Ug2(2,2,i-2)=0.0d0
2463         endif
2464         if (i .gt. 3 .and. i .lt. nres+1) then
2465           obrot_der(1,i-2)=-sin1
2466           obrot_der(2,i-2)= cos1
2467           Ugder(1,1,i-2)= sin1
2468           Ugder(1,2,i-2)=-cos1
2469           Ugder(2,1,i-2)=-cos1
2470           Ugder(2,2,i-2)=-sin1
2471           dwacos2=cos2+cos2
2472           dwasin2=sin2+sin2
2473           obrot2_der(1,i-2)=-dwasin2
2474           obrot2_der(2,i-2)= dwacos2
2475           Ug2der(1,1,i-2)= dwasin2
2476           Ug2der(1,2,i-2)=-dwacos2
2477           Ug2der(2,1,i-2)=-dwacos2
2478           Ug2der(2,2,i-2)=-dwasin2
2479         else
2480           obrot_der(1,i-2)=0.0d0
2481           obrot_der(2,i-2)=0.0d0
2482           Ugder(1,1,i-2)=0.0d0
2483           Ugder(1,2,i-2)=0.0d0
2484           Ugder(2,1,i-2)=0.0d0
2485           Ugder(2,2,i-2)=0.0d0
2486           obrot2_der(1,i-2)=0.0d0
2487           obrot2_der(2,i-2)=0.0d0
2488           Ug2der(1,1,i-2)=0.0d0
2489           Ug2der(1,2,i-2)=0.0d0
2490           Ug2der(2,1,i-2)=0.0d0
2491           Ug2der(2,2,i-2)=0.0d0
2492         endif
2493 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2494         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2495           iti = itortyp(itype(i-2,1))
2496         else
2497           iti=ntortyp+1
2498         endif
2499 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2500         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2501           iti1 = itortyp(itype(i-1,1))
2502         else
2503           iti1=ntortyp+1
2504         endif
2505 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2506 !d        write (iout,*) '*******i',i,' iti1',iti
2507 !d        write (iout,*) 'b1',b1(:,iti)
2508 !d        write (iout,*) 'b2',b2(:,iti)
2509 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2510 !        if (i .gt. iatel_s+2) then
2511         if (i .gt. nnt+2) then
2512           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2513           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2514           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2515           then
2516           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2517           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2518           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2519           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2520           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2521           endif
2522         else
2523           do k=1,2
2524             Ub2(k,i-2)=0.0d0
2525             Ctobr(k,i-2)=0.0d0
2526             Dtobr2(k,i-2)=0.0d0
2527             do l=1,2
2528               EUg(l,k,i-2)=0.0d0
2529               CUg(l,k,i-2)=0.0d0
2530               DUg(l,k,i-2)=0.0d0
2531               DtUg2(l,k,i-2)=0.0d0
2532             enddo
2533           enddo
2534         endif
2535         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2536         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2537         do k=1,2
2538           muder(k,i-2)=Ub2der(k,i-2)
2539         enddo
2540 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2541         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2542           if (itype(i-1,1).le.ntyp) then
2543             iti1 = itortyp(itype(i-1,1))
2544           else
2545             iti1=ntortyp+1
2546           endif
2547         else
2548           iti1=ntortyp+1
2549         endif
2550         do k=1,2
2551           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2552         enddo
2553 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2554 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2555 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2556 !d        write (iout,*) 'mu1',mu1(:,i-2)
2557 !d        write (iout,*) 'mu2',mu2(:,i-2)
2558         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2559         then
2560         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2561         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2562         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2563         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2564         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2565 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2566         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2567         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2568         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2569         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2570         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2571         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2572         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2573         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2574         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2575         endif
2576       enddo
2577 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2578 ! The order of matrices is from left to right.
2579       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2580       then
2581 !      do i=max0(ivec_start,2),ivec_end
2582       do i=2,nres-1
2583         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2584         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2585         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2586         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2587         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2588         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2589         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2590         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2591       enddo
2592       endif
2593 #if defined(MPI) && defined(PARMAT)
2594 #ifdef DEBUG
2595 !      if (fg_rank.eq.0) then
2596         write (iout,*) "Arrays UG and UGDER before GATHER"
2597         do i=1,nres-1
2598           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2599            ((ug(l,k,i),l=1,2),k=1,2),&
2600            ((ugder(l,k,i),l=1,2),k=1,2)
2601         enddo
2602         write (iout,*) "Arrays UG2 and UG2DER"
2603         do i=1,nres-1
2604           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2605            ((ug2(l,k,i),l=1,2),k=1,2),&
2606            ((ug2der(l,k,i),l=1,2),k=1,2)
2607         enddo
2608         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2609         do i=1,nres-1
2610           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2611            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2612            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2613         enddo
2614         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2615         do i=1,nres-1
2616           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2617            costab(i),sintab(i),costab2(i),sintab2(i)
2618         enddo
2619         write (iout,*) "Array MUDER"
2620         do i=1,nres-1
2621           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2622         enddo
2623 !      endif
2624 #endif
2625       if (nfgtasks.gt.1) then
2626         time00=MPI_Wtime()
2627 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2628 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2629 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2630 #ifdef MATGATHER
2631         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2632          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2633          FG_COMM1,IERR)
2634         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2635          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2636          FG_COMM1,IERR)
2637         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2638          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2639          FG_COMM1,IERR)
2640         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2641          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2642          FG_COMM1,IERR)
2643         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2644          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2645          FG_COMM1,IERR)
2646         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2647          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2648          FG_COMM1,IERR)
2649         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2650          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2651          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2652         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2653          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2654          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2655         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2656          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2657          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2658         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2659          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2660          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2661         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2662         then
2663         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2664          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2665          FG_COMM1,IERR)
2666         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2667          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2668          FG_COMM1,IERR)
2669         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2670          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2671          FG_COMM1,IERR)
2672        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2673          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2674          FG_COMM1,IERR)
2675         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2676          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2677          FG_COMM1,IERR)
2678         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2679          ivec_count(fg_rank1),&
2680          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2681          FG_COMM1,IERR)
2682         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2683          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2684          FG_COMM1,IERR)
2685         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2686          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2687          FG_COMM1,IERR)
2688         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2689          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2690          FG_COMM1,IERR)
2691         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2692          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2693          FG_COMM1,IERR)
2694         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2695          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2696          FG_COMM1,IERR)
2697         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2698          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2699          FG_COMM1,IERR)
2700         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2701          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2702          FG_COMM1,IERR)
2703         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2704          ivec_count(fg_rank1),&
2705          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2706          FG_COMM1,IERR)
2707         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2708          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2709          FG_COMM1,IERR)
2710        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2711          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2712          FG_COMM1,IERR)
2713         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2714          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2715          FG_COMM1,IERR)
2716        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2717          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2718          FG_COMM1,IERR)
2719         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2720          ivec_count(fg_rank1),&
2721          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2722          FG_COMM1,IERR)
2723         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2724          ivec_count(fg_rank1),&
2725          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2726          FG_COMM1,IERR)
2727         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2728          ivec_count(fg_rank1),&
2729          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2730          MPI_MAT2,FG_COMM1,IERR)
2731         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2732          ivec_count(fg_rank1),&
2733          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2734          MPI_MAT2,FG_COMM1,IERR)
2735         endif
2736 #else
2737 ! Passes matrix info through the ring
2738       isend=fg_rank1
2739       irecv=fg_rank1-1
2740       if (irecv.lt.0) irecv=nfgtasks1-1
2741       iprev=irecv
2742       inext=fg_rank1+1
2743       if (inext.ge.nfgtasks1) inext=0
2744       do i=1,nfgtasks1-1
2745 !        write (iout,*) "isend",isend," irecv",irecv
2746 !        call flush(iout)
2747         lensend=lentyp(isend)
2748         lenrecv=lentyp(irecv)
2749 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2750 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2751 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2752 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2753 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2754 !        write (iout,*) "Gather ROTAT1"
2755 !        call flush(iout)
2756 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2757 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2758 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2759 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2760 !        write (iout,*) "Gather ROTAT2"
2761 !        call flush(iout)
2762         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2763          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2764          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2765          iprev,4400+irecv,FG_COMM,status,IERR)
2766 !        write (iout,*) "Gather ROTAT_OLD"
2767 !        call flush(iout)
2768         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2769          MPI_PRECOMP11(lensend),inext,5500+isend,&
2770          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2771          iprev,5500+irecv,FG_COMM,status,IERR)
2772 !        write (iout,*) "Gather PRECOMP11"
2773 !        call flush(iout)
2774         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2775          MPI_PRECOMP12(lensend),inext,6600+isend,&
2776          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2777          iprev,6600+irecv,FG_COMM,status,IERR)
2778 !        write (iout,*) "Gather PRECOMP12"
2779 !        call flush(iout)
2780         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2781         then
2782         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2783          MPI_ROTAT2(lensend),inext,7700+isend,&
2784          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2785          iprev,7700+irecv,FG_COMM,status,IERR)
2786 !        write (iout,*) "Gather PRECOMP21"
2787 !        call flush(iout)
2788         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2789          MPI_PRECOMP22(lensend),inext,8800+isend,&
2790          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2791          iprev,8800+irecv,FG_COMM,status,IERR)
2792 !        write (iout,*) "Gather PRECOMP22"
2793 !        call flush(iout)
2794         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2795          MPI_PRECOMP23(lensend),inext,9900+isend,&
2796          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2797          MPI_PRECOMP23(lenrecv),&
2798          iprev,9900+irecv,FG_COMM,status,IERR)
2799 !        write (iout,*) "Gather PRECOMP23"
2800 !        call flush(iout)
2801         endif
2802         isend=irecv
2803         irecv=irecv-1
2804         if (irecv.lt.0) irecv=nfgtasks1-1
2805       enddo
2806 #endif
2807         time_gather=time_gather+MPI_Wtime()-time00
2808       endif
2809 #ifdef DEBUG
2810 !      if (fg_rank.eq.0) then
2811         write (iout,*) "Arrays UG and UGDER"
2812         do i=1,nres-1
2813           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2814            ((ug(l,k,i),l=1,2),k=1,2),&
2815            ((ugder(l,k,i),l=1,2),k=1,2)
2816         enddo
2817         write (iout,*) "Arrays UG2 and UG2DER"
2818         do i=1,nres-1
2819           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2820            ((ug2(l,k,i),l=1,2),k=1,2),&
2821            ((ug2der(l,k,i),l=1,2),k=1,2)
2822         enddo
2823         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2824         do i=1,nres-1
2825           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2826            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2827            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2828         enddo
2829         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2830         do i=1,nres-1
2831           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2832            costab(i),sintab(i),costab2(i),sintab2(i)
2833         enddo
2834         write (iout,*) "Array MUDER"
2835         do i=1,nres-1
2836           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2837         enddo
2838 !      endif
2839 #endif
2840 #endif
2841 !d      do i=1,nres
2842 !d        iti = itortyp(itype(i,1))
2843 !d        write (iout,*) i
2844 !d        do j=1,2
2845 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2846 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2847 !d        enddo
2848 !d      enddo
2849       return
2850       end subroutine set_matrices
2851 !-----------------------------------------------------------------------------
2852       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2853 !
2854 ! This subroutine calculates the average interaction energy and its gradient
2855 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2856 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2857 ! The potential depends both on the distance of peptide-group centers and on
2858 ! the orientation of the CA-CA virtual bonds.
2859 !
2860       use comm_locel
2861 !      implicit real*8 (a-h,o-z)
2862 #ifdef MPI
2863       include 'mpif.h'
2864 #endif
2865 !      include 'DIMENSIONS'
2866 !      include 'COMMON.CONTROL'
2867 !      include 'COMMON.SETUP'
2868 !      include 'COMMON.IOUNITS'
2869 !      include 'COMMON.GEO'
2870 !      include 'COMMON.VAR'
2871 !      include 'COMMON.LOCAL'
2872 !      include 'COMMON.CHAIN'
2873 !      include 'COMMON.DERIV'
2874 !      include 'COMMON.INTERACT'
2875 !      include 'COMMON.CONTACTS'
2876 !      include 'COMMON.TORSION'
2877 !      include 'COMMON.VECTORS'
2878 !      include 'COMMON.FFIELD'
2879 !      include 'COMMON.TIME1'
2880       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2881       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2882       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2883 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2884       real(kind=8),dimension(4) :: muij
2885 !el      integer :: num_conti,j1,j2
2886 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2887 !el        dz_normi,xmedi,ymedi,zmedi
2888
2889 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2890 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2891 !el          num_conti,j1,j2
2892
2893 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2894 #ifdef MOMENT
2895       real(kind=8) :: scal_el=1.0d0
2896 #else
2897       real(kind=8) :: scal_el=0.5d0
2898 #endif
2899 ! 12/13/98
2900 ! 13-go grudnia roku pamietnego...
2901       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2902                                              0.0d0,1.0d0,0.0d0,&
2903                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2904 !el local variables
2905       integer :: i,k,j
2906       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2907       real(kind=8) :: fac,t_eelecij,fracinbuf
2908
2909
2910 !d      write(iout,*) 'In EELEC'
2911 !        print *,"IN EELEC"
2912 !d      do i=1,nloctyp
2913 !d        write(iout,*) 'Type',i
2914 !d        write(iout,*) 'B1',B1(:,i)
2915 !d        write(iout,*) 'B2',B2(:,i)
2916 !d        write(iout,*) 'CC',CC(:,:,i)
2917 !d        write(iout,*) 'DD',DD(:,:,i)
2918 !d        write(iout,*) 'EE',EE(:,:,i)
2919 !d      enddo
2920 !d      call check_vecgrad
2921 !d      stop
2922 !      ees=0.0d0  !AS
2923 !      evdw1=0.0d0
2924 !      eel_loc=0.0d0
2925 !      eello_turn3=0.0d0
2926 !      eello_turn4=0.0d0
2927       t_eelecij=0.0d0
2928       ees=0.0D0
2929       evdw1=0.0D0
2930       eel_loc=0.0d0
2931       eello_turn3=0.0d0
2932       eello_turn4=0.0d0
2933 !
2934
2935       if (icheckgrad.eq.1) then
2936 !el
2937 !        do i=0,2*nres+2
2938 !          dc_norm(1,i)=0.0d0
2939 !          dc_norm(2,i)=0.0d0
2940 !          dc_norm(3,i)=0.0d0
2941 !        enddo
2942         do i=1,nres-1
2943           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2944           do k=1,3
2945             dc_norm(k,i)=dc(k,i)*fac
2946           enddo
2947 !          write (iout,*) 'i',i,' fac',fac
2948         enddo
2949       endif
2950 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
2951 !        wturn6
2952       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2953           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2954           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2955 !        call vec_and_deriv
2956 #ifdef TIMING
2957         time01=MPI_Wtime()
2958 #endif
2959 !        print *, "before set matrices"
2960         call set_matrices
2961 !        print *, "after set matrices"
2962
2963 #ifdef TIMING
2964         time_mat=time_mat+MPI_Wtime()-time01
2965 #endif
2966       endif
2967 !       print *, "after set matrices"
2968 !d      do i=1,nres-1
2969 !d        write (iout,*) 'i=',i
2970 !d        do k=1,3
2971 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2972 !d        enddo
2973 !d        do k=1,3
2974 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2975 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2976 !d        enddo
2977 !d      enddo
2978       t_eelecij=0.0d0
2979       ees=0.0D0
2980       evdw1=0.0D0
2981       eel_loc=0.0d0
2982       eello_turn3=0.0d0
2983       eello_turn4=0.0d0
2984 !el      ind=0
2985       do i=1,nres
2986         num_cont_hb(i)=0
2987       enddo
2988 !d      print '(a)','Enter EELEC'
2989 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2990 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2991 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2992       do i=1,nres
2993         gel_loc_loc(i)=0.0d0
2994         gcorr_loc(i)=0.0d0
2995       enddo
2996 !
2997 !
2998 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2999 !
3000 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3001 !
3002
3003
3004 !        print *,"before iturn3 loop"
3005       do i=iturn3_start,iturn3_end
3006         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3007         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3008         dxi=dc(1,i)
3009         dyi=dc(2,i)
3010         dzi=dc(3,i)
3011         dx_normi=dc_norm(1,i)
3012         dy_normi=dc_norm(2,i)
3013         dz_normi=dc_norm(3,i)
3014         xmedi=c(1,i)+0.5d0*dxi
3015         ymedi=c(2,i)+0.5d0*dyi
3016         zmedi=c(3,i)+0.5d0*dzi
3017           xmedi=dmod(xmedi,boxxsize)
3018           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3019           ymedi=dmod(ymedi,boxysize)
3020           if (ymedi.lt.0) ymedi=ymedi+boxysize
3021           zmedi=dmod(zmedi,boxzsize)
3022           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3023         num_conti=0
3024        if ((zmedi.gt.bordlipbot) &
3025         .and.(zmedi.lt.bordliptop)) then
3026 !C the energy transfer exist
3027         if (zmedi.lt.buflipbot) then
3028 !C what fraction I am in
3029          fracinbuf=1.0d0- &
3030                ((zmedi-bordlipbot)/lipbufthick)
3031 !C lipbufthick is thickenes of lipid buffore
3032          sslipi=sscalelip(fracinbuf)
3033          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3034         elseif (zmedi.gt.bufliptop) then
3035          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3036          sslipi=sscalelip(fracinbuf)
3037          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3038         else
3039          sslipi=1.0d0
3040          ssgradlipi=0.0
3041         endif
3042        else
3043          sslipi=0.0d0
3044          ssgradlipi=0.0
3045        endif
3046 !       print *,i,sslipi,ssgradlipi
3047        call eelecij(i,i+2,ees,evdw1,eel_loc)
3048         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3049         num_cont_hb(i)=num_conti
3050       enddo
3051       do i=iturn4_start,iturn4_end
3052         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3053           .or. itype(i+3,1).eq.ntyp1 &
3054           .or. itype(i+4,1).eq.ntyp1) cycle
3055         dxi=dc(1,i)
3056         dyi=dc(2,i)
3057         dzi=dc(3,i)
3058         dx_normi=dc_norm(1,i)
3059         dy_normi=dc_norm(2,i)
3060         dz_normi=dc_norm(3,i)
3061         xmedi=c(1,i)+0.5d0*dxi
3062         ymedi=c(2,i)+0.5d0*dyi
3063         zmedi=c(3,i)+0.5d0*dzi
3064           xmedi=dmod(xmedi,boxxsize)
3065           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3066           ymedi=dmod(ymedi,boxysize)
3067           if (ymedi.lt.0) ymedi=ymedi+boxysize
3068           zmedi=dmod(zmedi,boxzsize)
3069           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3070        if ((zmedi.gt.bordlipbot)  &
3071        .and.(zmedi.lt.bordliptop)) then
3072 !C the energy transfer exist
3073         if (zmedi.lt.buflipbot) then
3074 !C what fraction I am in
3075          fracinbuf=1.0d0- &
3076              ((zmedi-bordlipbot)/lipbufthick)
3077 !C lipbufthick is thickenes of lipid buffore
3078          sslipi=sscalelip(fracinbuf)
3079          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3080         elseif (zmedi.gt.bufliptop) then
3081          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3082          sslipi=sscalelip(fracinbuf)
3083          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3084         else
3085          sslipi=1.0d0
3086          ssgradlipi=0.0
3087         endif
3088        else
3089          sslipi=0.0d0
3090          ssgradlipi=0.0
3091        endif
3092
3093         num_conti=num_cont_hb(i)
3094         call eelecij(i,i+3,ees,evdw1,eel_loc)
3095         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3096          call eturn4(i,eello_turn4)
3097         num_cont_hb(i)=num_conti
3098       enddo   ! i
3099 !
3100 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3101 !
3102 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3103       do i=iatel_s,iatel_e
3104         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3105         dxi=dc(1,i)
3106         dyi=dc(2,i)
3107         dzi=dc(3,i)
3108         dx_normi=dc_norm(1,i)
3109         dy_normi=dc_norm(2,i)
3110         dz_normi=dc_norm(3,i)
3111         xmedi=c(1,i)+0.5d0*dxi
3112         ymedi=c(2,i)+0.5d0*dyi
3113         zmedi=c(3,i)+0.5d0*dzi
3114           xmedi=dmod(xmedi,boxxsize)
3115           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3116           ymedi=dmod(ymedi,boxysize)
3117           if (ymedi.lt.0) ymedi=ymedi+boxysize
3118           zmedi=dmod(zmedi,boxzsize)
3119           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3120        if ((zmedi.gt.bordlipbot)  &
3121         .and.(zmedi.lt.bordliptop)) then
3122 !C the energy transfer exist
3123         if (zmedi.lt.buflipbot) then
3124 !C what fraction I am in
3125          fracinbuf=1.0d0- &
3126              ((zmedi-bordlipbot)/lipbufthick)
3127 !C lipbufthick is thickenes of lipid buffore
3128          sslipi=sscalelip(fracinbuf)
3129          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3130         elseif (zmedi.gt.bufliptop) then
3131          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3132          sslipi=sscalelip(fracinbuf)
3133          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3134         else
3135          sslipi=1.0d0
3136          ssgradlipi=0.0
3137         endif
3138        else
3139          sslipi=0.0d0
3140          ssgradlipi=0.0
3141        endif
3142
3143 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3144         num_conti=num_cont_hb(i)
3145         do j=ielstart(i),ielend(i)
3146 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3147           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3148           call eelecij(i,j,ees,evdw1,eel_loc)
3149         enddo ! j
3150         num_cont_hb(i)=num_conti
3151       enddo   ! i
3152 !      write (iout,*) "Number of loop steps in EELEC:",ind
3153 !d      do i=1,nres
3154 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3155 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3156 !d      enddo
3157 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3158 !cc      eel_loc=eel_loc+eello_turn3
3159 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3160       return
3161       end subroutine eelec
3162 !-----------------------------------------------------------------------------
3163       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3164
3165       use comm_locel
3166 !      implicit real*8 (a-h,o-z)
3167 !      include 'DIMENSIONS'
3168 #ifdef MPI
3169       include "mpif.h"
3170 #endif
3171 !      include 'COMMON.CONTROL'
3172 !      include 'COMMON.IOUNITS'
3173 !      include 'COMMON.GEO'
3174 !      include 'COMMON.VAR'
3175 !      include 'COMMON.LOCAL'
3176 !      include 'COMMON.CHAIN'
3177 !      include 'COMMON.DERIV'
3178 !      include 'COMMON.INTERACT'
3179 !      include 'COMMON.CONTACTS'
3180 !      include 'COMMON.TORSION'
3181 !      include 'COMMON.VECTORS'
3182 !      include 'COMMON.FFIELD'
3183 !      include 'COMMON.TIME1'
3184       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3185       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3186       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3187 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3188       real(kind=8),dimension(4) :: muij
3189       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3190                     dist_temp, dist_init,rlocshield,fracinbuf
3191       integer xshift,yshift,zshift,ilist,iresshield
3192 !el      integer :: num_conti,j1,j2
3193 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3194 !el        dz_normi,xmedi,ymedi,zmedi
3195
3196 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3197 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3198 !el          num_conti,j1,j2
3199
3200 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3201 #ifdef MOMENT
3202       real(kind=8) :: scal_el=1.0d0
3203 #else
3204       real(kind=8) :: scal_el=0.5d0
3205 #endif
3206 ! 12/13/98
3207 ! 13-go grudnia roku pamietnego...
3208       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3209                                              0.0d0,1.0d0,0.0d0,&
3210                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3211 !      integer :: maxconts=nres/4
3212 !el local variables
3213       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3214       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3215       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3216       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3217                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3218                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3219                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3220                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3221                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3222                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3223                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3224 !      maxconts=nres/4
3225 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3226 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3227
3228 !          time00=MPI_Wtime()
3229 !d      write (iout,*) "eelecij",i,j
3230 !          ind=ind+1
3231           iteli=itel(i)
3232           itelj=itel(j)
3233           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3234           aaa=app(iteli,itelj)
3235           bbb=bpp(iteli,itelj)
3236           ael6i=ael6(iteli,itelj)
3237           ael3i=ael3(iteli,itelj)
3238           dxj=dc(1,j)
3239           dyj=dc(2,j)
3240           dzj=dc(3,j)
3241           dx_normj=dc_norm(1,j)
3242           dy_normj=dc_norm(2,j)
3243           dz_normj=dc_norm(3,j)
3244 !          xj=c(1,j)+0.5D0*dxj-xmedi
3245 !          yj=c(2,j)+0.5D0*dyj-ymedi
3246 !          zj=c(3,j)+0.5D0*dzj-zmedi
3247           xj=c(1,j)+0.5D0*dxj
3248           yj=c(2,j)+0.5D0*dyj
3249           zj=c(3,j)+0.5D0*dzj
3250           xj=mod(xj,boxxsize)
3251           if (xj.lt.0) xj=xj+boxxsize
3252           yj=mod(yj,boxysize)
3253           if (yj.lt.0) yj=yj+boxysize
3254           zj=mod(zj,boxzsize)
3255           if (zj.lt.0) zj=zj+boxzsize
3256        if ((zj.gt.bordlipbot)  &
3257        .and.(zj.lt.bordliptop)) then
3258 !C the energy transfer exist
3259         if (zj.lt.buflipbot) then
3260 !C what fraction I am in
3261          fracinbuf=1.0d0-     &
3262              ((zj-bordlipbot)/lipbufthick)
3263 !C lipbufthick is thickenes of lipid buffore
3264          sslipj=sscalelip(fracinbuf)
3265          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3266         elseif (zj.gt.bufliptop) then
3267          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3268          sslipj=sscalelip(fracinbuf)
3269          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3270         else
3271          sslipj=1.0d0
3272          ssgradlipj=0.0
3273         endif
3274        else
3275          sslipj=0.0d0
3276          ssgradlipj=0.0
3277        endif
3278
3279       isubchap=0
3280       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3281       xj_safe=xj
3282       yj_safe=yj
3283       zj_safe=zj
3284       do xshift=-1,1
3285       do yshift=-1,1
3286       do zshift=-1,1
3287           xj=xj_safe+xshift*boxxsize
3288           yj=yj_safe+yshift*boxysize
3289           zj=zj_safe+zshift*boxzsize
3290           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3291           if(dist_temp.lt.dist_init) then
3292             dist_init=dist_temp
3293             xj_temp=xj
3294             yj_temp=yj
3295             zj_temp=zj
3296             isubchap=1
3297           endif
3298        enddo
3299        enddo
3300        enddo
3301        if (isubchap.eq.1) then
3302 !C          print *,i,j
3303           xj=xj_temp-xmedi
3304           yj=yj_temp-ymedi
3305           zj=zj_temp-zmedi
3306        else
3307           xj=xj_safe-xmedi
3308           yj=yj_safe-ymedi
3309           zj=zj_safe-zmedi
3310        endif
3311
3312           rij=xj*xj+yj*yj+zj*zj
3313           rrmij=1.0D0/rij
3314           rij=dsqrt(rij)
3315 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3316             sss_ele_cut=sscale_ele(rij)
3317             sss_ele_grad=sscagrad_ele(rij)
3318 !             sss_ele_cut=1.0d0
3319 !             sss_ele_grad=0.0d0
3320 !            print *,sss_ele_cut,sss_ele_grad,&
3321 !            (rij),r_cut_ele,rlamb_ele
3322 !            if (sss_ele_cut.le.0.0) go to 128
3323
3324           rmij=1.0D0/rij
3325           r3ij=rrmij*rmij
3326           r6ij=r3ij*r3ij
3327           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3328           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3329           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3330           fac=cosa-3.0D0*cosb*cosg
3331           ev1=aaa*r6ij*r6ij
3332 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3333           if (j.eq.i+2) ev1=scal_el*ev1
3334           ev2=bbb*r6ij
3335           fac3=ael6i*r6ij
3336           fac4=ael3i*r3ij
3337           evdwij=ev1+ev2
3338           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3339           el2=fac4*fac
3340 !          eesij=el1+el2
3341           if (shield_mode.gt.0) then
3342 !C          fac_shield(i)=0.4
3343 !C          fac_shield(j)=0.6
3344           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3345           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3346           eesij=(el1+el2)
3347           ees=ees+eesij*sss_ele_cut
3348 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3349 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3350           else
3351           fac_shield(i)=1.0
3352           fac_shield(j)=1.0
3353           eesij=(el1+el2)
3354           ees=ees+eesij   &
3355             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3356 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3357           endif
3358
3359 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3360           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3361 !          ees=ees+eesij*sss_ele_cut
3362           evdw1=evdw1+evdwij*sss_ele_cut  &
3363            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3364 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3365 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3366 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3367 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3368
3369           if (energy_dec) then
3370 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3371 !                  'evdw1',i,j,evdwij,&
3372 !                  iteli,itelj,aaa,evdw1
3373               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3374               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3375           endif
3376 !
3377 ! Calculate contributions to the Cartesian gradient.
3378 !
3379 #ifdef SPLITELE
3380           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3381               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3382           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3383              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3384           fac1=fac
3385           erij(1)=xj*rmij
3386           erij(2)=yj*rmij
3387           erij(3)=zj*rmij
3388 !
3389 ! Radial derivatives. First process both termini of the fragment (i,j)
3390 !
3391           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3392           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3393           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3394            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3395           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3396             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3397
3398           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3399           (shield_mode.gt.0)) then
3400 !C          print *,i,j
3401           do ilist=1,ishield_list(i)
3402            iresshield=shield_list(ilist,i)
3403            do k=1,3
3404            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3405            *2.0*sss_ele_cut
3406            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3407                    rlocshield &
3408             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3409             *sss_ele_cut
3410             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3411            enddo
3412           enddo
3413           do ilist=1,ishield_list(j)
3414            iresshield=shield_list(ilist,j)
3415            do k=1,3
3416            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3417           *2.0*sss_ele_cut
3418            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3419                    rlocshield &
3420            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3421            *sss_ele_cut
3422            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3423            enddo
3424           enddo
3425           do k=1,3
3426             gshieldc(k,i)=gshieldc(k,i)+ &
3427                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3428            *sss_ele_cut
3429
3430             gshieldc(k,j)=gshieldc(k,j)+ &
3431                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3432            *sss_ele_cut
3433
3434             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3435                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3436            *sss_ele_cut
3437
3438             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3439                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3440            *sss_ele_cut
3441
3442            enddo
3443            endif
3444
3445
3446 !          do k=1,3
3447 !            ghalf=0.5D0*ggg(k)
3448 !            gelc(k,i)=gelc(k,i)+ghalf
3449 !            gelc(k,j)=gelc(k,j)+ghalf
3450 !          enddo
3451 ! 9/28/08 AL Gradient compotents will be summed only at the end
3452           do k=1,3
3453             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3454             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3455           enddo
3456             gelc_long(3,j)=gelc_long(3,j)+  &
3457           ssgradlipj*eesij/2.0d0*lipscale**2&
3458            *sss_ele_cut
3459
3460             gelc_long(3,i)=gelc_long(3,i)+  &
3461           ssgradlipi*eesij/2.0d0*lipscale**2&
3462            *sss_ele_cut
3463
3464
3465 !
3466 ! Loop over residues i+1 thru j-1.
3467 !
3468 !grad          do k=i+1,j-1
3469 !grad            do l=1,3
3470 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3471 !grad            enddo
3472 !grad          enddo
3473           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3474            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3475           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3476            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3477           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3478            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3479
3480 !          do k=1,3
3481 !            ghalf=0.5D0*ggg(k)
3482 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3483 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3484 !          enddo
3485 ! 9/28/08 AL Gradient compotents will be summed only at the end
3486           do k=1,3
3487             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3488             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3489           enddo
3490
3491 !C Lipidic part for scaling weight
3492            gvdwpp(3,j)=gvdwpp(3,j)+ &
3493           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3494            gvdwpp(3,i)=gvdwpp(3,i)+ &
3495           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3496 !! Loop over residues i+1 thru j-1.
3497 !
3498 !grad          do k=i+1,j-1
3499 !grad            do l=1,3
3500 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3501 !grad            enddo
3502 !grad          enddo
3503 #else
3504           facvdw=(ev1+evdwij)*sss_ele_cut &
3505            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3506
3507           facel=(el1+eesij)*sss_ele_cut
3508           fac1=fac
3509           fac=-3*rrmij*(facvdw+facvdw+facel)
3510           erij(1)=xj*rmij
3511           erij(2)=yj*rmij
3512           erij(3)=zj*rmij
3513 !
3514 ! Radial derivatives. First process both termini of the fragment (i,j)
3515 !
3516           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3517           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3518           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3519 !          do k=1,3
3520 !            ghalf=0.5D0*ggg(k)
3521 !            gelc(k,i)=gelc(k,i)+ghalf
3522 !            gelc(k,j)=gelc(k,j)+ghalf
3523 !          enddo
3524 ! 9/28/08 AL Gradient compotents will be summed only at the end
3525           do k=1,3
3526             gelc_long(k,j)=gelc(k,j)+ggg(k)
3527             gelc_long(k,i)=gelc(k,i)-ggg(k)
3528           enddo
3529 !
3530 ! Loop over residues i+1 thru j-1.
3531 !
3532 !grad          do k=i+1,j-1
3533 !grad            do l=1,3
3534 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3535 !grad            enddo
3536 !grad          enddo
3537 ! 9/28/08 AL Gradient compotents will be summed only at the end
3538           ggg(1)=facvdw*xj &
3539            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3540           ggg(2)=facvdw*yj &
3541            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3542           ggg(3)=facvdw*zj &
3543            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3544
3545           do k=1,3
3546             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3547             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3548           enddo
3549            gvdwpp(3,j)=gvdwpp(3,j)+ &
3550           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3551            gvdwpp(3,i)=gvdwpp(3,i)+ &
3552           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3553
3554 #endif
3555 !
3556 ! Angular part
3557 !
3558           ecosa=2.0D0*fac3*fac1+fac4
3559           fac4=-3.0D0*fac4
3560           fac3=-6.0D0*fac3
3561           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3562           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3563           do k=1,3
3564             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3565             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3566           enddo
3567 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3568 !d   &          (dcosg(k),k=1,3)
3569           do k=1,3
3570             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3571              *fac_shield(i)**2*fac_shield(j)**2 &
3572              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3573
3574           enddo
3575 !          do k=1,3
3576 !            ghalf=0.5D0*ggg(k)
3577 !            gelc(k,i)=gelc(k,i)+ghalf
3578 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3579 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3580 !            gelc(k,j)=gelc(k,j)+ghalf
3581 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3582 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3583 !          enddo
3584 !grad          do k=i+1,j-1
3585 !grad            do l=1,3
3586 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3587 !grad            enddo
3588 !grad          enddo
3589           do k=1,3
3590             gelc(k,i)=gelc(k,i) &
3591                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3592                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3593                      *sss_ele_cut &
3594                      *fac_shield(i)**2*fac_shield(j)**2 &
3595                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3596
3597             gelc(k,j)=gelc(k,j) &
3598                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3599                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3600                      *sss_ele_cut  &
3601                      *fac_shield(i)**2*fac_shield(j)**2  &
3602                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3603
3604             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3605             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3606           enddo
3607
3608           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3609               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3610               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3611 !
3612 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3613 !   energy of a peptide unit is assumed in the form of a second-order
3614 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3615 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3616 !   are computed for EVERY pair of non-contiguous peptide groups.
3617 !
3618           if (j.lt.nres-1) then
3619             j1=j+1
3620             j2=j-1
3621           else
3622             j1=j-1
3623             j2=j-2
3624           endif
3625           kkk=0
3626           do k=1,2
3627             do l=1,2
3628               kkk=kkk+1
3629               muij(kkk)=mu(k,i)*mu(l,j)
3630             enddo
3631           enddo
3632 !d         write (iout,*) 'EELEC: i',i,' j',j
3633 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3634 !d          write(iout,*) 'muij',muij
3635           ury=scalar(uy(1,i),erij)
3636           urz=scalar(uz(1,i),erij)
3637           vry=scalar(uy(1,j),erij)
3638           vrz=scalar(uz(1,j),erij)
3639           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3640           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3641           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3642           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3643           fac=dsqrt(-ael6i)*r3ij
3644           a22=a22*fac
3645           a23=a23*fac
3646           a32=a32*fac
3647           a33=a33*fac
3648 !d          write (iout,'(4i5,4f10.5)')
3649 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3650 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3651 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3652 !d     &      uy(:,j),uz(:,j)
3653 !d          write (iout,'(4f10.5)')
3654 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3655 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3656 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3657 !d           write (iout,'(9f10.5/)')
3658 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3659 ! Derivatives of the elements of A in virtual-bond vectors
3660           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3661           do k=1,3
3662             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3663             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3664             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3665             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3666             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3667             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3668             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3669             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3670             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3671             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3672             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3673             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3674           enddo
3675 ! Compute radial contributions to the gradient
3676           facr=-3.0d0*rrmij
3677           a22der=a22*facr
3678           a23der=a23*facr
3679           a32der=a32*facr
3680           a33der=a33*facr
3681           agg(1,1)=a22der*xj
3682           agg(2,1)=a22der*yj
3683           agg(3,1)=a22der*zj
3684           agg(1,2)=a23der*xj
3685           agg(2,2)=a23der*yj
3686           agg(3,2)=a23der*zj
3687           agg(1,3)=a32der*xj
3688           agg(2,3)=a32der*yj
3689           agg(3,3)=a32der*zj
3690           agg(1,4)=a33der*xj
3691           agg(2,4)=a33der*yj
3692           agg(3,4)=a33der*zj
3693 ! Add the contributions coming from er
3694           fac3=-3.0d0*fac
3695           do k=1,3
3696             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3697             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3698             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3699             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3700           enddo
3701           do k=1,3
3702 ! Derivatives in DC(i)
3703 !grad            ghalf1=0.5d0*agg(k,1)
3704 !grad            ghalf2=0.5d0*agg(k,2)
3705 !grad            ghalf3=0.5d0*agg(k,3)
3706 !grad            ghalf4=0.5d0*agg(k,4)
3707             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3708             -3.0d0*uryg(k,2)*vry)!+ghalf1
3709             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3710             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3711             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3712             -3.0d0*urzg(k,2)*vry)!+ghalf3
3713             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3714             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3715 ! Derivatives in DC(i+1)
3716             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3717             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3718             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3719             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3720             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3721             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3722             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3723             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3724 ! Derivatives in DC(j)
3725             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3726             -3.0d0*vryg(k,2)*ury)!+ghalf1
3727             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3728             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3729             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3730             -3.0d0*vryg(k,2)*urz)!+ghalf3
3731             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3732             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3733 ! Derivatives in DC(j+1) or DC(nres-1)
3734             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3735             -3.0d0*vryg(k,3)*ury)
3736             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3737             -3.0d0*vrzg(k,3)*ury)
3738             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3739             -3.0d0*vryg(k,3)*urz)
3740             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3741             -3.0d0*vrzg(k,3)*urz)
3742 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3743 !grad              do l=1,4
3744 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3745 !grad              enddo
3746 !grad            endif
3747           enddo
3748           acipa(1,1)=a22
3749           acipa(1,2)=a23
3750           acipa(2,1)=a32
3751           acipa(2,2)=a33
3752           a22=-a22
3753           a23=-a23
3754           do l=1,2
3755             do k=1,3
3756               agg(k,l)=-agg(k,l)
3757               aggi(k,l)=-aggi(k,l)
3758               aggi1(k,l)=-aggi1(k,l)
3759               aggj(k,l)=-aggj(k,l)
3760               aggj1(k,l)=-aggj1(k,l)
3761             enddo
3762           enddo
3763           if (j.lt.nres-1) then
3764             a22=-a22
3765             a32=-a32
3766             do l=1,3,2
3767               do k=1,3
3768                 agg(k,l)=-agg(k,l)
3769                 aggi(k,l)=-aggi(k,l)
3770                 aggi1(k,l)=-aggi1(k,l)
3771                 aggj(k,l)=-aggj(k,l)
3772                 aggj1(k,l)=-aggj1(k,l)
3773               enddo
3774             enddo
3775           else
3776             a22=-a22
3777             a23=-a23
3778             a32=-a32
3779             a33=-a33
3780             do l=1,4
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           endif
3790           ENDIF ! WCORR
3791           IF (wel_loc.gt.0.0d0) THEN
3792 ! Contribution to the local-electrostatic energy coming from the i-j pair
3793           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3794            +a33*muij(4)
3795           if (shield_mode.eq.0) then
3796            fac_shield(i)=1.0
3797            fac_shield(j)=1.0
3798           endif
3799           eel_loc_ij=eel_loc_ij &
3800          *fac_shield(i)*fac_shield(j) &
3801          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3802 !C Now derivative over eel_loc
3803           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3804          (shield_mode.gt.0)) then
3805 !C          print *,i,j
3806
3807           do ilist=1,ishield_list(i)
3808            iresshield=shield_list(ilist,i)
3809            do k=1,3
3810            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3811                                                 /fac_shield(i)&
3812            *sss_ele_cut
3813            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3814                    rlocshield  &
3815           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3816           *sss_ele_cut
3817
3818             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3819            +rlocshield
3820            enddo
3821           enddo
3822           do ilist=1,ishield_list(j)
3823            iresshield=shield_list(ilist,j)
3824            do k=1,3
3825            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3826                                             /fac_shield(j)   &
3827             *sss_ele_cut
3828            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3829                    rlocshield  &
3830       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3831        *sss_ele_cut
3832
3833            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3834                   +rlocshield
3835
3836            enddo
3837           enddo
3838
3839           do k=1,3
3840             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3841                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3842                     *sss_ele_cut
3843             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3844                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3845                     *sss_ele_cut
3846             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3847                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3848                     *sss_ele_cut
3849             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3850                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3851                     *sss_ele_cut
3852
3853            enddo
3854            endif
3855
3856
3857 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3858 !           eel_loc_ij=0.0
3859           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3860                   'eelloc',i,j,eel_loc_ij
3861 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3862 !          if (energy_dec) write (iout,*) "muij",muij
3863 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3864
3865           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3866 ! Partial derivatives in virtual-bond dihedral angles gamma
3867           if (i.gt.1) &
3868           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3869                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3870                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3871                  *sss_ele_cut  &
3872           *fac_shield(i)*fac_shield(j) &
3873           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3874
3875           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3876                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3877                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3878                  *sss_ele_cut &
3879           *fac_shield(i)*fac_shield(j) &
3880           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3881 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3882 !          do l=1,3
3883 !            ggg(1)=(agg(1,1)*muij(1)+ &
3884 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3885 !            *sss_ele_cut &
3886 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3887 !            ggg(2)=(agg(2,1)*muij(1)+ &
3888 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3889 !            *sss_ele_cut &
3890 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3891 !            ggg(3)=(agg(3,1)*muij(1)+ &
3892 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3893 !            *sss_ele_cut &
3894 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3895            xtemp(1)=xj
3896            xtemp(2)=yj
3897            xtemp(3)=zj
3898
3899            do l=1,3
3900             ggg(l)=(agg(l,1)*muij(1)+ &
3901                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3902             *sss_ele_cut &
3903           *fac_shield(i)*fac_shield(j) &
3904           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
3905              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3906
3907
3908             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3909             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3910 !grad            ghalf=0.5d0*ggg(l)
3911 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3912 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3913           enddo
3914             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
3915           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
3916           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3917
3918             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
3919           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
3920           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3921
3922 !grad          do k=i+1,j2
3923 !grad            do l=1,3
3924 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3925 !grad            enddo
3926 !grad          enddo
3927 ! Remaining derivatives of eello
3928           do l=1,3
3929             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
3930                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
3931             *sss_ele_cut &
3932           *fac_shield(i)*fac_shield(j) &
3933           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3934
3935 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3936             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
3937                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
3938             +aggi1(l,4)*muij(4))&
3939             *sss_ele_cut &
3940           *fac_shield(i)*fac_shield(j) &
3941           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3942
3943 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3944             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
3945                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
3946             *sss_ele_cut &
3947           *fac_shield(i)*fac_shield(j) &
3948           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3949
3950 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3951             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
3952                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
3953             +aggj1(l,4)*muij(4))&
3954             *sss_ele_cut &
3955           *fac_shield(i)*fac_shield(j) &
3956           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3957
3958 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3959           enddo
3960           ENDIF
3961 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3962 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3963           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3964              .and. num_conti.le.maxconts) then
3965 !            write (iout,*) i,j," entered corr"
3966 !
3967 ! Calculate the contact function. The ith column of the array JCONT will
3968 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3969 ! greater than I). The arrays FACONT and GACONT will contain the values of
3970 ! the contact function and its derivative.
3971 !           r0ij=1.02D0*rpp(iteli,itelj)
3972 !           r0ij=1.11D0*rpp(iteli,itelj)
3973             r0ij=2.20D0*rpp(iteli,itelj)
3974 !           r0ij=1.55D0*rpp(iteli,itelj)
3975             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3976 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3977             if (fcont.gt.0.0D0) then
3978               num_conti=num_conti+1
3979               if (num_conti.gt.maxconts) then
3980 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3981 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3982                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3983                                ' will skip next contacts for this conf.', num_conti
3984               else
3985                 jcont_hb(num_conti,i)=j
3986 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3987 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3988                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3989                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3990 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3991 !  terms.
3992                 d_cont(num_conti,i)=rij
3993 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3994 !     --- Electrostatic-interaction matrix ---
3995                 a_chuj(1,1,num_conti,i)=a22
3996                 a_chuj(1,2,num_conti,i)=a23
3997                 a_chuj(2,1,num_conti,i)=a32
3998                 a_chuj(2,2,num_conti,i)=a33
3999 !     --- Gradient of rij
4000                 do kkk=1,3
4001                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4002                 enddo
4003                 kkll=0
4004                 do k=1,2
4005                   do l=1,2
4006                     kkll=kkll+1
4007                     do m=1,3
4008                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4009                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4010                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4011                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4012                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4013                     enddo
4014                   enddo
4015                 enddo
4016                 ENDIF
4017                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4018 ! Calculate contact energies
4019                 cosa4=4.0D0*cosa
4020                 wij=cosa-3.0D0*cosb*cosg
4021                 cosbg1=cosb+cosg
4022                 cosbg2=cosb-cosg
4023 !               fac3=dsqrt(-ael6i)/r0ij**3
4024                 fac3=dsqrt(-ael6i)*r3ij
4025 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4026                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4027                 if (ees0tmp.gt.0) then
4028                   ees0pij=dsqrt(ees0tmp)
4029                 else
4030                   ees0pij=0
4031                 endif
4032                 if (shield_mode.eq.0) then
4033                 fac_shield(i)=1.0d0
4034                 fac_shield(j)=1.0d0
4035                 else
4036                 ees0plist(num_conti,i)=j
4037                 endif
4038 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4039                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4040                 if (ees0tmp.gt.0) then
4041                   ees0mij=dsqrt(ees0tmp)
4042                 else
4043                   ees0mij=0
4044                 endif
4045 !               ees0mij=0.0D0
4046                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4047                      *sss_ele_cut &
4048                      *fac_shield(i)*fac_shield(j)
4049
4050                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4051                      *sss_ele_cut &
4052                      *fac_shield(i)*fac_shield(j)
4053
4054 ! Diagnostics. Comment out or remove after debugging!
4055 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4056 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4057 !               ees0m(num_conti,i)=0.0D0
4058 ! End diagnostics.
4059 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4060 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4061 ! Angular derivatives of the contact function
4062                 ees0pij1=fac3/ees0pij
4063                 ees0mij1=fac3/ees0mij
4064                 fac3p=-3.0D0*fac3*rrmij
4065                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4066                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4067 !               ees0mij1=0.0D0
4068                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4069                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4070                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4071                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4072                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4073                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4074                 ecosap=ecosa1+ecosa2
4075                 ecosbp=ecosb1+ecosb2
4076                 ecosgp=ecosg1+ecosg2
4077                 ecosam=ecosa1-ecosa2
4078                 ecosbm=ecosb1-ecosb2
4079                 ecosgm=ecosg1-ecosg2
4080 ! Diagnostics
4081 !               ecosap=ecosa1
4082 !               ecosbp=ecosb1
4083 !               ecosgp=ecosg1
4084 !               ecosam=0.0D0
4085 !               ecosbm=0.0D0
4086 !               ecosgm=0.0D0
4087 ! End diagnostics
4088                 facont_hb(num_conti,i)=fcont
4089                 fprimcont=fprimcont/rij
4090 !d              facont_hb(num_conti,i)=1.0D0
4091 ! Following line is for diagnostics.
4092 !d              fprimcont=0.0D0
4093                 do k=1,3
4094                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4095                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4096                 enddo
4097                 do k=1,3
4098                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4099                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4100                 enddo
4101                 gggp(1)=gggp(1)+ees0pijp*xj &
4102                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4103                 gggp(2)=gggp(2)+ees0pijp*yj &
4104                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4105                 gggp(3)=gggp(3)+ees0pijp*zj &
4106                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4107
4108                 gggm(1)=gggm(1)+ees0mijp*xj &
4109                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4110
4111                 gggm(2)=gggm(2)+ees0mijp*yj &
4112                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4113
4114                 gggm(3)=gggm(3)+ees0mijp*zj &
4115                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4116
4117 ! Derivatives due to the contact function
4118                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4119                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4120                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4121                 do k=1,3
4122 !
4123 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4124 !          following the change of gradient-summation algorithm.
4125 !
4126 !grad                  ghalfp=0.5D0*gggp(k)
4127 !grad                  ghalfm=0.5D0*gggm(k)
4128                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4129                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4130                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4131                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4132
4133                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4134                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4135                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4136                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4137
4138                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4139                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4140
4141                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4142                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4143                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4144                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4145
4146                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4147                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4148                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4149                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4150
4151                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4152                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4153
4154                 enddo
4155 ! Diagnostics. Comment out or remove after debugging!
4156 !diag           do k=1,3
4157 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4158 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4159 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4160 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4161 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4162 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4163 !diag           enddo
4164               ENDIF ! wcorr
4165               endif  ! num_conti.le.maxconts
4166             endif  ! fcont.gt.0
4167           endif    ! j.gt.i+1
4168           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4169             do k=1,4
4170               do l=1,3
4171                 ghalf=0.5d0*agg(l,k)
4172                 aggi(l,k)=aggi(l,k)+ghalf
4173                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4174                 aggj(l,k)=aggj(l,k)+ghalf
4175               enddo
4176             enddo
4177             if (j.eq.nres-1 .and. i.lt.j-2) then
4178               do k=1,4
4179                 do l=1,3
4180                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4181                 enddo
4182               enddo
4183             endif
4184           endif
4185  128  continue
4186 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4187       return
4188       end subroutine eelecij
4189 !-----------------------------------------------------------------------------
4190       subroutine eturn3(i,eello_turn3)
4191 ! Third- and fourth-order contributions from turns
4192
4193       use comm_locel
4194 !      implicit real*8 (a-h,o-z)
4195 !      include 'DIMENSIONS'
4196 !      include 'COMMON.IOUNITS'
4197 !      include 'COMMON.GEO'
4198 !      include 'COMMON.VAR'
4199 !      include 'COMMON.LOCAL'
4200 !      include 'COMMON.CHAIN'
4201 !      include 'COMMON.DERIV'
4202 !      include 'COMMON.INTERACT'
4203 !      include 'COMMON.CONTACTS'
4204 !      include 'COMMON.TORSION'
4205 !      include 'COMMON.VECTORS'
4206 !      include 'COMMON.FFIELD'
4207 !      include 'COMMON.CONTROL'
4208       real(kind=8),dimension(3) :: ggg
4209       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4210         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4211       real(kind=8),dimension(2) :: auxvec,auxvec1
4212 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4213       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4214 !el      integer :: num_conti,j1,j2
4215 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4216 !el        dz_normi,xmedi,ymedi,zmedi
4217
4218 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4219 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4220 !el         num_conti,j1,j2
4221 !el local variables
4222       integer :: i,j,l,k,ilist,iresshield
4223       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4224
4225       j=i+2
4226 !      write (iout,*) "eturn3",i,j,j1,j2
4227           zj=(c(3,j)+c(3,j+1))/2.0d0
4228           zj=mod(zj,boxzsize)
4229           if (zj.lt.0) zj=zj+boxzsize
4230           if ((zj.lt.0)) write (*,*) "CHUJ"
4231        if ((zj.gt.bordlipbot)  &
4232         .and.(zj.lt.bordliptop)) then
4233 !C the energy transfer exist
4234         if (zj.lt.buflipbot) then
4235 !C what fraction I am in
4236          fracinbuf=1.0d0-     &
4237              ((zj-bordlipbot)/lipbufthick)
4238 !C lipbufthick is thickenes of lipid buffore
4239          sslipj=sscalelip(fracinbuf)
4240          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4241         elseif (zj.gt.bufliptop) then
4242          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4243          sslipj=sscalelip(fracinbuf)
4244          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4245         else
4246          sslipj=1.0d0
4247          ssgradlipj=0.0
4248         endif
4249        else
4250          sslipj=0.0d0
4251          ssgradlipj=0.0
4252        endif
4253
4254       a_temp(1,1)=a22
4255       a_temp(1,2)=a23
4256       a_temp(2,1)=a32
4257       a_temp(2,2)=a33
4258 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4259 !
4260 !               Third-order contributions
4261 !
4262 !                 (i+2)o----(i+3)
4263 !                      | |
4264 !                      | |
4265 !                 (i+1)o----i
4266 !
4267 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4268 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4269         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4270         call transpose2(auxmat(1,1),auxmat1(1,1))
4271         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4272         if (shield_mode.eq.0) then
4273         fac_shield(i)=1.0d0
4274         fac_shield(j)=1.0d0
4275         endif
4276
4277         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4278          *fac_shield(i)*fac_shield(j)  &
4279          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4280         eello_t3= &
4281         0.5d0*(pizda(1,1)+pizda(2,2)) &
4282         *fac_shield(i)*fac_shield(j)
4283
4284         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4285                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4286           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4287        (shield_mode.gt.0)) then
4288 !C          print *,i,j
4289
4290           do ilist=1,ishield_list(i)
4291            iresshield=shield_list(ilist,i)
4292            do k=1,3
4293            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4294            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4295                    rlocshield &
4296            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4297             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4298              +rlocshield
4299            enddo
4300           enddo
4301           do ilist=1,ishield_list(j)
4302            iresshield=shield_list(ilist,j)
4303            do k=1,3
4304            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4305            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4306                    rlocshield &
4307            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4308            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4309                   +rlocshield
4310
4311            enddo
4312           enddo
4313
4314           do k=1,3
4315             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4316                    grad_shield(k,i)*eello_t3/fac_shield(i)
4317             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4318                    grad_shield(k,j)*eello_t3/fac_shield(j)
4319             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4320                    grad_shield(k,i)*eello_t3/fac_shield(i)
4321             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4322                    grad_shield(k,j)*eello_t3/fac_shield(j)
4323            enddo
4324            endif
4325
4326 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4327 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4328 !d     &    ' eello_turn3_num',4*eello_turn3_num
4329 ! Derivatives in gamma(i)
4330         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4331         call transpose2(auxmat2(1,1),auxmat3(1,1))
4332         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4333         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4334           *fac_shield(i)*fac_shield(j)        &
4335           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4336 ! Derivatives in gamma(i+1)
4337         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4338         call transpose2(auxmat2(1,1),auxmat3(1,1))
4339         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4340         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4341           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4342           *fac_shield(i)*fac_shield(j)        &
4343           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4344
4345 ! Cartesian derivatives
4346         do l=1,3
4347 !            ghalf1=0.5d0*agg(l,1)
4348 !            ghalf2=0.5d0*agg(l,2)
4349 !            ghalf3=0.5d0*agg(l,3)
4350 !            ghalf4=0.5d0*agg(l,4)
4351           a_temp(1,1)=aggi(l,1)!+ghalf1
4352           a_temp(1,2)=aggi(l,2)!+ghalf2
4353           a_temp(2,1)=aggi(l,3)!+ghalf3
4354           a_temp(2,2)=aggi(l,4)!+ghalf4
4355           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4356           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4357             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4358           *fac_shield(i)*fac_shield(j)      &
4359           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4360
4361           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4362           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4363           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4364           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4365           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4366           gcorr3_turn(l,i+1)=gcorr3_turn(l,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           a_temp(1,1)=aggj(l,1)!+ghalf1
4372           a_temp(1,2)=aggj(l,2)!+ghalf2
4373           a_temp(2,1)=aggj(l,3)!+ghalf3
4374           a_temp(2,2)=aggj(l,4)!+ghalf4
4375           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4376           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4377             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4378           *fac_shield(i)*fac_shield(j)      &
4379           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4380
4381           a_temp(1,1)=aggj1(l,1)
4382           a_temp(1,2)=aggj1(l,2)
4383           a_temp(2,1)=aggj1(l,3)
4384           a_temp(2,2)=aggj1(l,4)
4385           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4386           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4387             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4388           *fac_shield(i)*fac_shield(j)        &
4389           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4390         enddo
4391          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4392           ssgradlipi*eello_t3/4.0d0*lipscale
4393          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4394           ssgradlipj*eello_t3/4.0d0*lipscale
4395          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4396           ssgradlipi*eello_t3/4.0d0*lipscale
4397          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4398           ssgradlipj*eello_t3/4.0d0*lipscale
4399
4400       return
4401       end subroutine eturn3
4402 !-----------------------------------------------------------------------------
4403       subroutine eturn4(i,eello_turn4)
4404 ! Third- and fourth-order contributions from turns
4405
4406       use comm_locel
4407 !      implicit real*8 (a-h,o-z)
4408 !      include 'DIMENSIONS'
4409 !      include 'COMMON.IOUNITS'
4410 !      include 'COMMON.GEO'
4411 !      include 'COMMON.VAR'
4412 !      include 'COMMON.LOCAL'
4413 !      include 'COMMON.CHAIN'
4414 !      include 'COMMON.DERIV'
4415 !      include 'COMMON.INTERACT'
4416 !      include 'COMMON.CONTACTS'
4417 !      include 'COMMON.TORSION'
4418 !      include 'COMMON.VECTORS'
4419 !      include 'COMMON.FFIELD'
4420 !      include 'COMMON.CONTROL'
4421       real(kind=8),dimension(3) :: ggg
4422       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4423         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4424       real(kind=8),dimension(2) :: auxvec,auxvec1
4425 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4426       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4427 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4428 !el        dz_normi,xmedi,ymedi,zmedi
4429 !el      integer :: num_conti,j1,j2
4430 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4431 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4432 !el          num_conti,j1,j2
4433 !el local variables
4434       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4435       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4436          rlocshield
4437
4438       j=i+3
4439 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4440 !
4441 !               Fourth-order contributions
4442 !
4443 !                 (i+3)o----(i+4)
4444 !                     /  |
4445 !               (i+2)o   |
4446 !                     \  |
4447 !                 (i+1)o----i
4448 !
4449 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4450 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4451 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4452           zj=(c(3,j)+c(3,j+1))/2.0d0
4453           zj=mod(zj,boxzsize)
4454           if (zj.lt.0) zj=zj+boxzsize
4455        if ((zj.gt.bordlipbot)  &
4456         .and.(zj.lt.bordliptop)) then
4457 !C the energy transfer exist
4458         if (zj.lt.buflipbot) then
4459 !C what fraction I am in
4460          fracinbuf=1.0d0-     &
4461              ((zj-bordlipbot)/lipbufthick)
4462 !C lipbufthick is thickenes of lipid buffore
4463          sslipj=sscalelip(fracinbuf)
4464          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4465         elseif (zj.gt.bufliptop) then
4466          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4467          sslipj=sscalelip(fracinbuf)
4468          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4469         else
4470          sslipj=1.0d0
4471          ssgradlipj=0.0
4472         endif
4473        else
4474          sslipj=0.0d0
4475          ssgradlipj=0.0
4476        endif
4477
4478         a_temp(1,1)=a22
4479         a_temp(1,2)=a23
4480         a_temp(2,1)=a32
4481         a_temp(2,2)=a33
4482         iti1=itortyp(itype(i+1,1))
4483         iti2=itortyp(itype(i+2,1))
4484         iti3=itortyp(itype(i+3,1))
4485 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4486         call transpose2(EUg(1,1,i+1),e1t(1,1))
4487         call transpose2(Eug(1,1,i+2),e2t(1,1))
4488         call transpose2(Eug(1,1,i+3),e3t(1,1))
4489         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4490         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4491         s1=scalar2(b1(1,iti2),auxvec(1))
4492         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4493         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4494         s2=scalar2(b1(1,iti1),auxvec(1))
4495         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4496         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4497         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4498         if (shield_mode.eq.0) then
4499         fac_shield(i)=1.0
4500         fac_shield(j)=1.0
4501         endif
4502
4503         eello_turn4=eello_turn4-(s1+s2+s3) &
4504         *fac_shield(i)*fac_shield(j)       &
4505         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4506         eello_t4=-(s1+s2+s3)  &
4507           *fac_shield(i)*fac_shield(j)
4508 !C Now derivative over shield:
4509           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4510          (shield_mode.gt.0)) then
4511 !C          print *,i,j
4512
4513           do ilist=1,ishield_list(i)
4514            iresshield=shield_list(ilist,i)
4515            do k=1,3
4516            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4517            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4518                    rlocshield &
4519             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4520             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4521            +rlocshield
4522            enddo
4523           enddo
4524           do ilist=1,ishield_list(j)
4525            iresshield=shield_list(ilist,j)
4526            do k=1,3
4527            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4528            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4529                    rlocshield  &
4530            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4531            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4532                   +rlocshield
4533
4534            enddo
4535           enddo
4536
4537           do k=1,3
4538             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4539                    grad_shield(k,i)*eello_t4/fac_shield(i)
4540             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4541                    grad_shield(k,j)*eello_t4/fac_shield(j)
4542             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4543                    grad_shield(k,i)*eello_t4/fac_shield(i)
4544             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4545                    grad_shield(k,j)*eello_t4/fac_shield(j)
4546            enddo
4547            endif
4548
4549         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4550            'eturn4',i,j,-(s1+s2+s3)
4551 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4552 !d     &    ' eello_turn4_num',8*eello_turn4_num
4553 ! Derivatives in gamma(i)
4554         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4555         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4556         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4557         s1=scalar2(b1(1,iti2),auxvec(1))
4558         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4559         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4560         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4561        *fac_shield(i)*fac_shield(j)  &
4562        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4563
4564 ! Derivatives in gamma(i+1)
4565         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4566         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4567         s2=scalar2(b1(1,iti1),auxvec(1))
4568         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4569         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4570         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4571         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4572        *fac_shield(i)*fac_shield(j)  &
4573        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4574
4575 ! Derivatives in gamma(i+2)
4576         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4577         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4578         s1=scalar2(b1(1,iti2),auxvec(1))
4579         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4580         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4581         s2=scalar2(b1(1,iti1),auxvec(1))
4582         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4583         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4584         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4585         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4586        *fac_shield(i)*fac_shield(j)  &
4587        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4588
4589 ! Cartesian derivatives
4590 ! Derivatives of this turn contributions in DC(i+2)
4591         if (j.lt.nres-1) then
4592           do l=1,3
4593             a_temp(1,1)=agg(l,1)
4594             a_temp(1,2)=agg(l,2)
4595             a_temp(2,1)=agg(l,3)
4596             a_temp(2,2)=agg(l,4)
4597             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4598             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4599             s1=scalar2(b1(1,iti2),auxvec(1))
4600             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4601             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4602             s2=scalar2(b1(1,iti1),auxvec(1))
4603             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4604             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4605             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4606             ggg(l)=-(s1+s2+s3)
4607             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4608        *fac_shield(i)*fac_shield(j)  &
4609        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4610
4611           enddo
4612         endif
4613 ! Remaining derivatives of this turn contribution
4614         do l=1,3
4615           a_temp(1,1)=aggi(l,1)
4616           a_temp(1,2)=aggi(l,2)
4617           a_temp(2,1)=aggi(l,3)
4618           a_temp(2,2)=aggi(l,4)
4619           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4620           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4621           s1=scalar2(b1(1,iti2),auxvec(1))
4622           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4623           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4624           s2=scalar2(b1(1,iti1),auxvec(1))
4625           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4626           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4627           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4628           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4629          *fac_shield(i)*fac_shield(j)  &
4630          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4631
4632
4633           a_temp(1,1)=aggi1(l,1)
4634           a_temp(1,2)=aggi1(l,2)
4635           a_temp(2,1)=aggi1(l,3)
4636           a_temp(2,2)=aggi1(l,4)
4637           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4638           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4639           s1=scalar2(b1(1,iti2),auxvec(1))
4640           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4641           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4642           s2=scalar2(b1(1,iti1),auxvec(1))
4643           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4644           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4645           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4646           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4647          *fac_shield(i)*fac_shield(j)  &
4648          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4649
4650
4651           a_temp(1,1)=aggj(l,1)
4652           a_temp(1,2)=aggj(l,2)
4653           a_temp(2,1)=aggj(l,3)
4654           a_temp(2,2)=aggj(l,4)
4655           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4656           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4657           s1=scalar2(b1(1,iti2),auxvec(1))
4658           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4659           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4660           s2=scalar2(b1(1,iti1),auxvec(1))
4661           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4662           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4663           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4664           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4665          *fac_shield(i)*fac_shield(j)  &
4666          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4667
4668
4669           a_temp(1,1)=aggj1(l,1)
4670           a_temp(1,2)=aggj1(l,2)
4671           a_temp(2,1)=aggj1(l,3)
4672           a_temp(2,2)=aggj1(l,4)
4673           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4674           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4675           s1=scalar2(b1(1,iti2),auxvec(1))
4676           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4677           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4678           s2=scalar2(b1(1,iti1),auxvec(1))
4679           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4680           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4681           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4682 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4683           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4684          *fac_shield(i)*fac_shield(j)  &
4685          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4686
4687         enddo
4688          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4689           ssgradlipi*eello_t4/4.0d0*lipscale
4690          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4691           ssgradlipj*eello_t4/4.0d0*lipscale
4692          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4693           ssgradlipi*eello_t4/4.0d0*lipscale
4694          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4695           ssgradlipj*eello_t4/4.0d0*lipscale
4696
4697       return
4698       end subroutine eturn4
4699 !-----------------------------------------------------------------------------
4700       subroutine unormderiv(u,ugrad,unorm,ungrad)
4701 ! This subroutine computes the derivatives of a normalized vector u, given
4702 ! the derivatives computed without normalization conditions, ugrad. Returns
4703 ! ungrad.
4704 !      implicit none
4705       real(kind=8),dimension(3) :: u,vec
4706       real(kind=8),dimension(3,3) ::ugrad,ungrad
4707       real(kind=8) :: unorm      !,scalar
4708       integer :: i,j
4709 !      write (2,*) 'ugrad',ugrad
4710 !      write (2,*) 'u',u
4711       do i=1,3
4712         vec(i)=scalar(ugrad(1,i),u(1))
4713       enddo
4714 !      write (2,*) 'vec',vec
4715       do i=1,3
4716         do j=1,3
4717           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4718         enddo
4719       enddo
4720 !      write (2,*) 'ungrad',ungrad
4721       return
4722       end subroutine unormderiv
4723 !-----------------------------------------------------------------------------
4724       subroutine escp_soft_sphere(evdw2,evdw2_14)
4725 !
4726 ! This subroutine calculates the excluded-volume interaction energy between
4727 ! peptide-group centers and side chains and its gradient in virtual-bond and
4728 ! side-chain vectors.
4729 !
4730 !      implicit real*8 (a-h,o-z)
4731 !      include 'DIMENSIONS'
4732 !      include 'COMMON.GEO'
4733 !      include 'COMMON.VAR'
4734 !      include 'COMMON.LOCAL'
4735 !      include 'COMMON.CHAIN'
4736 !      include 'COMMON.DERIV'
4737 !      include 'COMMON.INTERACT'
4738 !      include 'COMMON.FFIELD'
4739 !      include 'COMMON.IOUNITS'
4740 !      include 'COMMON.CONTROL'
4741       real(kind=8),dimension(3) :: ggg
4742 !el local variables
4743       integer :: i,iint,j,k,iteli,itypj
4744       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4745                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4746
4747       evdw2=0.0D0
4748       evdw2_14=0.0d0
4749       r0_scp=4.5d0
4750 !d    print '(a)','Enter ESCP'
4751 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4752       do i=iatscp_s,iatscp_e
4753         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4754         iteli=itel(i)
4755         xi=0.5D0*(c(1,i)+c(1,i+1))
4756         yi=0.5D0*(c(2,i)+c(2,i+1))
4757         zi=0.5D0*(c(3,i)+c(3,i+1))
4758
4759         do iint=1,nscp_gr(i)
4760
4761         do j=iscpstart(i,iint),iscpend(i,iint)
4762           if (itype(j,1).eq.ntyp1) cycle
4763           itypj=iabs(itype(j,1))
4764 ! Uncomment following three lines for SC-p interactions
4765 !         xj=c(1,nres+j)-xi
4766 !         yj=c(2,nres+j)-yi
4767 !         zj=c(3,nres+j)-zi
4768 ! Uncomment following three lines for Ca-p interactions
4769           xj=c(1,j)-xi
4770           yj=c(2,j)-yi
4771           zj=c(3,j)-zi
4772           rij=xj*xj+yj*yj+zj*zj
4773           r0ij=r0_scp
4774           r0ijsq=r0ij*r0ij
4775           if (rij.lt.r0ijsq) then
4776             evdwij=0.25d0*(rij-r0ijsq)**2
4777             fac=rij-r0ijsq
4778           else
4779             evdwij=0.0d0
4780             fac=0.0d0
4781           endif
4782           evdw2=evdw2+evdwij
4783 !
4784 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4785 !
4786           ggg(1)=xj*fac
4787           ggg(2)=yj*fac
4788           ggg(3)=zj*fac
4789 !grad          if (j.lt.i) then
4790 !d          write (iout,*) 'j<i'
4791 ! Uncomment following three lines for SC-p interactions
4792 !           do k=1,3
4793 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4794 !           enddo
4795 !grad          else
4796 !d          write (iout,*) 'j>i'
4797 !grad            do k=1,3
4798 !grad              ggg(k)=-ggg(k)
4799 ! Uncomment following line for SC-p interactions
4800 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4801 !grad            enddo
4802 !grad          endif
4803 !grad          do k=1,3
4804 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4805 !grad          enddo
4806 !grad          kstart=min0(i+1,j)
4807 !grad          kend=max0(i-1,j-1)
4808 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4809 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4810 !grad          do k=kstart,kend
4811 !grad            do l=1,3
4812 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4813 !grad            enddo
4814 !grad          enddo
4815           do k=1,3
4816             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4817             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4818           enddo
4819         enddo
4820
4821         enddo ! iint
4822       enddo ! i
4823       return
4824       end subroutine escp_soft_sphere
4825 !-----------------------------------------------------------------------------
4826       subroutine escp(evdw2,evdw2_14)
4827 !
4828 ! This subroutine calculates the excluded-volume interaction energy between
4829 ! peptide-group centers and side chains and its gradient in virtual-bond and
4830 ! side-chain vectors.
4831 !
4832 !      implicit real*8 (a-h,o-z)
4833 !      include 'DIMENSIONS'
4834 !      include 'COMMON.GEO'
4835 !      include 'COMMON.VAR'
4836 !      include 'COMMON.LOCAL'
4837 !      include 'COMMON.CHAIN'
4838 !      include 'COMMON.DERIV'
4839 !      include 'COMMON.INTERACT'
4840 !      include 'COMMON.FFIELD'
4841 !      include 'COMMON.IOUNITS'
4842 !      include 'COMMON.CONTROL'
4843       real(kind=8),dimension(3) :: ggg
4844 !el local variables
4845       integer :: i,iint,j,k,iteli,itypj,subchap
4846       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4847                    e1,e2,evdwij,rij
4848       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4849                     dist_temp, dist_init
4850       integer xshift,yshift,zshift
4851
4852       evdw2=0.0D0
4853       evdw2_14=0.0d0
4854 !d    print '(a)','Enter ESCP'
4855 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4856       do i=iatscp_s,iatscp_e
4857         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4858         iteli=itel(i)
4859         xi=0.5D0*(c(1,i)+c(1,i+1))
4860         yi=0.5D0*(c(2,i)+c(2,i+1))
4861         zi=0.5D0*(c(3,i)+c(3,i+1))
4862           xi=mod(xi,boxxsize)
4863           if (xi.lt.0) xi=xi+boxxsize
4864           yi=mod(yi,boxysize)
4865           if (yi.lt.0) yi=yi+boxysize
4866           zi=mod(zi,boxzsize)
4867           if (zi.lt.0) zi=zi+boxzsize
4868
4869         do iint=1,nscp_gr(i)
4870
4871         do j=iscpstart(i,iint),iscpend(i,iint)
4872           itypj=iabs(itype(j,1))
4873           if (itypj.eq.ntyp1) cycle
4874 ! Uncomment following three lines for SC-p interactions
4875 !         xj=c(1,nres+j)-xi
4876 !         yj=c(2,nres+j)-yi
4877 !         zj=c(3,nres+j)-zi
4878 ! Uncomment following three lines for Ca-p interactions
4879 !          xj=c(1,j)-xi
4880 !          yj=c(2,j)-yi
4881 !          zj=c(3,j)-zi
4882           xj=c(1,j)
4883           yj=c(2,j)
4884           zj=c(3,j)
4885           xj=mod(xj,boxxsize)
4886           if (xj.lt.0) xj=xj+boxxsize
4887           yj=mod(yj,boxysize)
4888           if (yj.lt.0) yj=yj+boxysize
4889           zj=mod(zj,boxzsize)
4890           if (zj.lt.0) zj=zj+boxzsize
4891       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4892       xj_safe=xj
4893       yj_safe=yj
4894       zj_safe=zj
4895       subchap=0
4896       do xshift=-1,1
4897       do yshift=-1,1
4898       do zshift=-1,1
4899           xj=xj_safe+xshift*boxxsize
4900           yj=yj_safe+yshift*boxysize
4901           zj=zj_safe+zshift*boxzsize
4902           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4903           if(dist_temp.lt.dist_init) then
4904             dist_init=dist_temp
4905             xj_temp=xj
4906             yj_temp=yj
4907             zj_temp=zj
4908             subchap=1
4909           endif
4910        enddo
4911        enddo
4912        enddo
4913        if (subchap.eq.1) then
4914           xj=xj_temp-xi
4915           yj=yj_temp-yi
4916           zj=zj_temp-zi
4917        else
4918           xj=xj_safe-xi
4919           yj=yj_safe-yi
4920           zj=zj_safe-zi
4921        endif
4922
4923           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4924           rij=dsqrt(1.0d0/rrij)
4925             sss_ele_cut=sscale_ele(rij)
4926             sss_ele_grad=sscagrad_ele(rij)
4927 !            print *,sss_ele_cut,sss_ele_grad,&
4928 !            (rij),r_cut_ele,rlamb_ele
4929             if (sss_ele_cut.le.0.0) cycle
4930           fac=rrij**expon2
4931           e1=fac*fac*aad(itypj,iteli)
4932           e2=fac*bad(itypj,iteli)
4933           if (iabs(j-i) .le. 2) then
4934             e1=scal14*e1
4935             e2=scal14*e2
4936             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
4937           endif
4938           evdwij=e1+e2
4939           evdw2=evdw2+evdwij*sss_ele_cut
4940 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
4941 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
4942           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4943              'evdw2',i,j,evdwij
4944 !
4945 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4946 !
4947           fac=-(evdwij+e1)*rrij*sss_ele_cut
4948           fac=fac+evdwij*sss_ele_grad/rij/expon
4949           ggg(1)=xj*fac
4950           ggg(2)=yj*fac
4951           ggg(3)=zj*fac
4952 !grad          if (j.lt.i) then
4953 !d          write (iout,*) 'j<i'
4954 ! Uncomment following three lines for SC-p interactions
4955 !           do k=1,3
4956 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4957 !           enddo
4958 !grad          else
4959 !d          write (iout,*) 'j>i'
4960 !grad            do k=1,3
4961 !grad              ggg(k)=-ggg(k)
4962 ! Uncomment following line for SC-p interactions
4963 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4964 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4965 !grad            enddo
4966 !grad          endif
4967 !grad          do k=1,3
4968 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4969 !grad          enddo
4970 !grad          kstart=min0(i+1,j)
4971 !grad          kend=max0(i-1,j-1)
4972 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4973 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4974 !grad          do k=kstart,kend
4975 !grad            do l=1,3
4976 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4977 !grad            enddo
4978 !grad          enddo
4979           do k=1,3
4980             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4981             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4982           enddo
4983         enddo
4984
4985         enddo ! iint
4986       enddo ! i
4987       do i=1,nct
4988         do j=1,3
4989           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4990           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4991           gradx_scp(j,i)=expon*gradx_scp(j,i)
4992         enddo
4993       enddo
4994 !******************************************************************************
4995 !
4996 !                              N O T E !!!
4997 !
4998 ! To save time the factor EXPON has been extracted from ALL components
4999 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5000 ! use!
5001 !
5002 !******************************************************************************
5003       return
5004       end subroutine escp
5005 !-----------------------------------------------------------------------------
5006       subroutine edis(ehpb)
5007 !
5008 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5009 !
5010 !      implicit real*8 (a-h,o-z)
5011 !      include 'DIMENSIONS'
5012 !      include 'COMMON.SBRIDGE'
5013 !      include 'COMMON.CHAIN'
5014 !      include 'COMMON.DERIV'
5015 !      include 'COMMON.VAR'
5016 !      include 'COMMON.INTERACT'
5017 !      include 'COMMON.IOUNITS'
5018       real(kind=8),dimension(3) :: ggg
5019 !el local variables
5020       integer :: i,j,ii,jj,iii,jjj,k
5021       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5022
5023       ehpb=0.0D0
5024 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5025 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5026       if (link_end.eq.0) return
5027       do i=link_start,link_end
5028 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5029 ! CA-CA distance used in regularization of structure.
5030         ii=ihpb(i)
5031         jj=jhpb(i)
5032 ! iii and jjj point to the residues for which the distance is assigned.
5033         if (ii.gt.nres) then
5034           iii=ii-nres
5035           jjj=jj-nres
5036         else
5037           iii=ii
5038           jjj=jj
5039         endif
5040 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5041 !     &    dhpb(i),dhpb1(i),forcon(i)
5042 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5043 !    distance and angle dependent SS bond potential.
5044 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5045 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5046         if (.not.dyn_ss .and. i.le.nss) then
5047 ! 15/02/13 CC dynamic SSbond - additional check
5048          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5049         iabs(itype(jjj,1)).eq.1) then
5050           call ssbond_ene(iii,jjj,eij)
5051           ehpb=ehpb+2*eij
5052 !d          write (iout,*) "eij",eij
5053          endif
5054         else if (ii.gt.nres .and. jj.gt.nres) then
5055 !c Restraints from contact prediction
5056           dd=dist(ii,jj)
5057           if (constr_dist.eq.11) then
5058             ehpb=ehpb+fordepth(i)**4.0d0 &
5059                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5060             fac=fordepth(i)**4.0d0 &
5061                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5062           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5063             ehpb,fordepth(i),dd
5064            else
5065           if (dhpb1(i).gt.0.0d0) then
5066             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5067             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5068 !c            write (iout,*) "beta nmr",
5069 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5070           else
5071             dd=dist(ii,jj)
5072             rdis=dd-dhpb(i)
5073 !C Get the force constant corresponding to this distance.
5074             waga=forcon(i)
5075 !C Calculate the contribution to energy.
5076             ehpb=ehpb+waga*rdis*rdis
5077 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5078 !C
5079 !C Evaluate gradient.
5080 !C
5081             fac=waga*rdis/dd
5082           endif
5083           endif
5084           do j=1,3
5085             ggg(j)=fac*(c(j,jj)-c(j,ii))
5086           enddo
5087           do j=1,3
5088             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5089             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5090           enddo
5091           do k=1,3
5092             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5093             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5094           enddo
5095         else
5096           dd=dist(ii,jj)
5097           if (constr_dist.eq.11) then
5098             ehpb=ehpb+fordepth(i)**4.0d0 &
5099                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5100             fac=fordepth(i)**4.0d0 &
5101                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5102           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5103          ehpb,fordepth(i),dd
5104            else
5105           if (dhpb1(i).gt.0.0d0) then
5106             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5107             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5108 !c            write (iout,*) "alph nmr",
5109 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5110           else
5111             rdis=dd-dhpb(i)
5112 !C Get the force constant corresponding to this distance.
5113             waga=forcon(i)
5114 !C Calculate the contribution to energy.
5115             ehpb=ehpb+waga*rdis*rdis
5116 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5117 !C
5118 !C Evaluate gradient.
5119 !C
5120             fac=waga*rdis/dd
5121           endif
5122           endif
5123
5124             do j=1,3
5125               ggg(j)=fac*(c(j,jj)-c(j,ii))
5126             enddo
5127 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5128 !C If this is a SC-SC distance, we need to calculate the contributions to the
5129 !C Cartesian gradient in the SC vectors (ghpbx).
5130           if (iii.lt.ii) then
5131           do j=1,3
5132             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5133             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5134           enddo
5135           endif
5136 !cgrad        do j=iii,jjj-1
5137 !cgrad          do k=1,3
5138 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5139 !cgrad          enddo
5140 !cgrad        enddo
5141           do k=1,3
5142             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5143             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5144           enddo
5145         endif
5146       enddo
5147       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5148
5149       return
5150       end subroutine edis
5151 !-----------------------------------------------------------------------------
5152       subroutine ssbond_ene(i,j,eij)
5153 !
5154 ! Calculate the distance and angle dependent SS-bond potential energy
5155 ! using a free-energy function derived based on RHF/6-31G** ab initio
5156 ! calculations of diethyl disulfide.
5157 !
5158 ! A. Liwo and U. Kozlowska, 11/24/03
5159 !
5160 !      implicit real*8 (a-h,o-z)
5161 !      include 'DIMENSIONS'
5162 !      include 'COMMON.SBRIDGE'
5163 !      include 'COMMON.CHAIN'
5164 !      include 'COMMON.DERIV'
5165 !      include 'COMMON.LOCAL'
5166 !      include 'COMMON.INTERACT'
5167 !      include 'COMMON.VAR'
5168 !      include 'COMMON.IOUNITS'
5169       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5170 !el local variables
5171       integer :: i,j,itypi,itypj,k
5172       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5173                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5174                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5175                    cosphi,ggk
5176
5177       itypi=iabs(itype(i,1))
5178       xi=c(1,nres+i)
5179       yi=c(2,nres+i)
5180       zi=c(3,nres+i)
5181       dxi=dc_norm(1,nres+i)
5182       dyi=dc_norm(2,nres+i)
5183       dzi=dc_norm(3,nres+i)
5184 !      dsci_inv=dsc_inv(itypi)
5185       dsci_inv=vbld_inv(nres+i)
5186       itypj=iabs(itype(j,1))
5187 !      dscj_inv=dsc_inv(itypj)
5188       dscj_inv=vbld_inv(nres+j)
5189       xj=c(1,nres+j)-xi
5190       yj=c(2,nres+j)-yi
5191       zj=c(3,nres+j)-zi
5192       dxj=dc_norm(1,nres+j)
5193       dyj=dc_norm(2,nres+j)
5194       dzj=dc_norm(3,nres+j)
5195       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5196       rij=dsqrt(rrij)
5197       erij(1)=xj*rij
5198       erij(2)=yj*rij
5199       erij(3)=zj*rij
5200       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5201       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5202       om12=dxi*dxj+dyi*dyj+dzi*dzj
5203       do k=1,3
5204         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5205         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5206       enddo
5207       rij=1.0d0/rij
5208       deltad=rij-d0cm
5209       deltat1=1.0d0-om1
5210       deltat2=1.0d0+om2
5211       deltat12=om2-om1+2.0d0
5212       cosphi=om12-om1*om2
5213       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5214         +akct*deltad*deltat12 &
5215         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5216 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5217 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5218 !     &  " deltat12",deltat12," eij",eij
5219       ed=2*akcm*deltad+akct*deltat12
5220       pom1=akct*deltad
5221       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5222       eom1=-2*akth*deltat1-pom1-om2*pom2
5223       eom2= 2*akth*deltat2+pom1-om1*pom2
5224       eom12=pom2
5225       do k=1,3
5226         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5227         ghpbx(k,i)=ghpbx(k,i)-ggk &
5228                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5229                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5230         ghpbx(k,j)=ghpbx(k,j)+ggk &
5231                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5232                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5233         ghpbc(k,i)=ghpbc(k,i)-ggk
5234         ghpbc(k,j)=ghpbc(k,j)+ggk
5235       enddo
5236 !
5237 ! Calculate the components of the gradient in DC and X
5238 !
5239 !grad      do k=i,j-1
5240 !grad        do l=1,3
5241 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5242 !grad        enddo
5243 !grad      enddo
5244       return
5245       end subroutine ssbond_ene
5246 !-----------------------------------------------------------------------------
5247       subroutine ebond(estr)
5248 !
5249 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5250 !
5251 !      implicit real*8 (a-h,o-z)
5252 !      include 'DIMENSIONS'
5253 !      include 'COMMON.LOCAL'
5254 !      include 'COMMON.GEO'
5255 !      include 'COMMON.INTERACT'
5256 !      include 'COMMON.DERIV'
5257 !      include 'COMMON.VAR'
5258 !      include 'COMMON.CHAIN'
5259 !      include 'COMMON.IOUNITS'
5260 !      include 'COMMON.NAMES'
5261 !      include 'COMMON.FFIELD'
5262 !      include 'COMMON.CONTROL'
5263 !      include 'COMMON.SETUP'
5264       real(kind=8),dimension(3) :: u,ud
5265 !el local variables
5266       integer :: i,j,iti,nbi,k
5267       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5268                    uprod1,uprod2
5269
5270       estr=0.0d0
5271       estr1=0.0d0
5272 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5273 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5274
5275       do i=ibondp_start,ibondp_end
5276         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5277         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5278 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5279 !C          do j=1,3
5280 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5281 !C            *dc(j,i-1)/vbld(i)
5282 !C          enddo
5283 !C          if (energy_dec) write(iout,*) &
5284 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5285         diff = vbld(i)-vbldpDUM
5286         else
5287         diff = vbld(i)-vbldp0
5288         endif
5289         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5290            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5291         estr=estr+diff*diff
5292         do j=1,3
5293           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5294         enddo
5295 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5296 !        endif
5297       enddo
5298       estr=0.5d0*AKP*estr+estr1
5299 !      print *,"estr_bb",estr,AKP
5300 !
5301 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5302 !
5303       do i=ibond_start,ibond_end
5304         iti=iabs(itype(i,1))
5305         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5306         if (iti.ne.10 .and. iti.ne.ntyp1) then
5307           nbi=nbondterm(iti)
5308           if (nbi.eq.1) then
5309             diff=vbld(i+nres)-vbldsc0(1,iti)
5310             if (energy_dec) write (iout,*) &
5311             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5312             AKSC(1,iti),AKSC(1,iti)*diff*diff
5313             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5314 !            print *,"estr_sc",estr
5315             do j=1,3
5316               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5317             enddo
5318           else
5319             do j=1,nbi
5320               diff=vbld(i+nres)-vbldsc0(j,iti)
5321               ud(j)=aksc(j,iti)*diff
5322               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5323             enddo
5324             uprod=u(1)
5325             do j=2,nbi
5326               uprod=uprod*u(j)
5327             enddo
5328             usum=0.0d0
5329             usumsqder=0.0d0
5330             do j=1,nbi
5331               uprod1=1.0d0
5332               uprod2=1.0d0
5333               do k=1,nbi
5334                 if (k.ne.j) then
5335                   uprod1=uprod1*u(k)
5336                   uprod2=uprod2*u(k)*u(k)
5337                 endif
5338               enddo
5339               usum=usum+uprod1
5340               usumsqder=usumsqder+ud(j)*uprod2
5341             enddo
5342             estr=estr+uprod/usum
5343 !            print *,"estr_sc",estr,i
5344
5345              if (energy_dec) write (iout,*) &
5346             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5347             AKSC(1,iti),uprod/usum
5348             do j=1,3
5349              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5350             enddo
5351           endif
5352         endif
5353       enddo
5354       return
5355       end subroutine ebond
5356 #ifdef CRYST_THETA
5357 !-----------------------------------------------------------------------------
5358       subroutine ebend(etheta)
5359 !
5360 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5361 ! angles gamma and its derivatives in consecutive thetas and gammas.
5362 !
5363       use comm_calcthet
5364 !      implicit real*8 (a-h,o-z)
5365 !      include 'DIMENSIONS'
5366 !      include 'COMMON.LOCAL'
5367 !      include 'COMMON.GEO'
5368 !      include 'COMMON.INTERACT'
5369 !      include 'COMMON.DERIV'
5370 !      include 'COMMON.VAR'
5371 !      include 'COMMON.CHAIN'
5372 !      include 'COMMON.IOUNITS'
5373 !      include 'COMMON.NAMES'
5374 !      include 'COMMON.FFIELD'
5375 !      include 'COMMON.CONTROL'
5376 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5377 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5378 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5379 !el      integer :: it
5380 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5381 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5382 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5383 !el local variables
5384       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5385        ichir21,ichir22
5386       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5387        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5388        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5389       real(kind=8),dimension(2) :: y,z
5390
5391       delta=0.02d0*pi
5392 !      time11=dexp(-2*time)
5393 !      time12=1.0d0
5394       etheta=0.0D0
5395 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5396       do i=ithet_start,ithet_end
5397         if (itype(i-1,1).eq.ntyp1) cycle
5398 ! Zero the energy function and its derivative at 0 or pi.
5399         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5400         it=itype(i-1,1)
5401         ichir1=isign(1,itype(i-2,1))
5402         ichir2=isign(1,itype(i,1))
5403          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5404          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5405          if (itype(i-1,1).eq.10) then
5406           itype1=isign(10,itype(i-2,1))
5407           ichir11=isign(1,itype(i-2,1))
5408           ichir12=isign(1,itype(i-2,1))
5409           itype2=isign(10,itype(i,1))
5410           ichir21=isign(1,itype(i,1))
5411           ichir22=isign(1,itype(i,1))
5412          endif
5413
5414         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5415 #ifdef OSF
5416           phii=phi(i)
5417           if (phii.ne.phii) phii=150.0
5418 #else
5419           phii=phi(i)
5420 #endif
5421           y(1)=dcos(phii)
5422           y(2)=dsin(phii)
5423         else
5424           y(1)=0.0D0
5425           y(2)=0.0D0
5426         endif
5427         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5428 #ifdef OSF
5429           phii1=phi(i+1)
5430           if (phii1.ne.phii1) phii1=150.0
5431           phii1=pinorm(phii1)
5432           z(1)=cos(phii1)
5433 #else
5434           phii1=phi(i+1)
5435           z(1)=dcos(phii1)
5436 #endif
5437           z(2)=dsin(phii1)
5438         else
5439           z(1)=0.0D0
5440           z(2)=0.0D0
5441         endif
5442 ! Calculate the "mean" value of theta from the part of the distribution
5443 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5444 ! In following comments this theta will be referred to as t_c.
5445         thet_pred_mean=0.0d0
5446         do k=1,2
5447             athetk=athet(k,it,ichir1,ichir2)
5448             bthetk=bthet(k,it,ichir1,ichir2)
5449           if (it.eq.10) then
5450              athetk=athet(k,itype1,ichir11,ichir12)
5451              bthetk=bthet(k,itype2,ichir21,ichir22)
5452           endif
5453          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5454         enddo
5455         dthett=thet_pred_mean*ssd
5456         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5457 ! Derivatives of the "mean" values in gamma1 and gamma2.
5458         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5459                +athet(2,it,ichir1,ichir2)*y(1))*ss
5460         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5461                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5462          if (it.eq.10) then
5463         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5464              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5465         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5466                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5467          endif
5468         if (theta(i).gt.pi-delta) then
5469           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5470                E_tc0)
5471           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5472           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5473           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5474               E_theta)
5475           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5476               E_tc)
5477         else if (theta(i).lt.delta) then
5478           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5479           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5480           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5481               E_theta)
5482           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5483           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5484               E_tc)
5485         else
5486           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5487               E_theta,E_tc)
5488         endif
5489         etheta=etheta+ethetai
5490         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5491             'ebend',i,ethetai
5492         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5493         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5494         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5495       enddo
5496 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5497
5498 ! Ufff.... We've done all this!!!
5499       return
5500       end subroutine ebend
5501 !-----------------------------------------------------------------------------
5502       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5503
5504       use comm_calcthet
5505 !      implicit real*8 (a-h,o-z)
5506 !      include 'DIMENSIONS'
5507 !      include 'COMMON.LOCAL'
5508 !      include 'COMMON.IOUNITS'
5509 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5510 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5511 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5512       integer :: i,j,k
5513       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5514 !el      integer :: it
5515 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5516 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5517 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5518 !el local variables
5519       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5520        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5521
5522 ! Calculate the contributions to both Gaussian lobes.
5523 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5524 ! The "polynomial part" of the "standard deviation" of this part of
5525 ! the distribution.
5526         sig=polthet(3,it)
5527         do j=2,0,-1
5528           sig=sig*thet_pred_mean+polthet(j,it)
5529         enddo
5530 ! Derivative of the "interior part" of the "standard deviation of the"
5531 ! gamma-dependent Gaussian lobe in t_c.
5532         sigtc=3*polthet(3,it)
5533         do j=2,1,-1
5534           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5535         enddo
5536         sigtc=sig*sigtc
5537 ! Set the parameters of both Gaussian lobes of the distribution.
5538 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5539         fac=sig*sig+sigc0(it)
5540         sigcsq=fac+fac
5541         sigc=1.0D0/sigcsq
5542 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5543         sigsqtc=-4.0D0*sigcsq*sigtc
5544 !       print *,i,sig,sigtc,sigsqtc
5545 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5546         sigtc=-sigtc/(fac*fac)
5547 ! Following variable is sigma(t_c)**(-2)
5548         sigcsq=sigcsq*sigcsq
5549         sig0i=sig0(it)
5550         sig0inv=1.0D0/sig0i**2
5551         delthec=thetai-thet_pred_mean
5552         delthe0=thetai-theta0i
5553         term1=-0.5D0*sigcsq*delthec*delthec
5554         term2=-0.5D0*sig0inv*delthe0*delthe0
5555 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5556 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5557 ! to the energy (this being the log of the distribution) at the end of energy
5558 ! term evaluation for this virtual-bond angle.
5559         if (term1.gt.term2) then
5560           termm=term1
5561           term2=dexp(term2-termm)
5562           term1=1.0d0
5563         else
5564           termm=term2
5565           term1=dexp(term1-termm)
5566           term2=1.0d0
5567         endif
5568 ! The ratio between the gamma-independent and gamma-dependent lobes of
5569 ! the distribution is a Gaussian function of thet_pred_mean too.
5570         diffak=gthet(2,it)-thet_pred_mean
5571         ratak=diffak/gthet(3,it)**2
5572         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5573 ! Let's differentiate it in thet_pred_mean NOW.
5574         aktc=ak*ratak
5575 ! Now put together the distribution terms to make complete distribution.
5576         termexp=term1+ak*term2
5577         termpre=sigc+ak*sig0i
5578 ! Contribution of the bending energy from this theta is just the -log of
5579 ! the sum of the contributions from the two lobes and the pre-exponential
5580 ! factor. Simple enough, isn't it?
5581         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5582 ! NOW the derivatives!!!
5583 ! 6/6/97 Take into account the deformation.
5584         E_theta=(delthec*sigcsq*term1 &
5585              +ak*delthe0*sig0inv*term2)/termexp
5586         E_tc=((sigtc+aktc*sig0i)/termpre &
5587             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5588              aktc*term2)/termexp)
5589       return
5590       end subroutine theteng
5591 #else
5592 !-----------------------------------------------------------------------------
5593       subroutine ebend(etheta,ethetacnstr)
5594 !
5595 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5596 ! angles gamma and its derivatives in consecutive thetas and gammas.
5597 ! ab initio-derived potentials from
5598 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5599 !
5600 !      implicit real*8 (a-h,o-z)
5601 !      include 'DIMENSIONS'
5602 !      include 'COMMON.LOCAL'
5603 !      include 'COMMON.GEO'
5604 !      include 'COMMON.INTERACT'
5605 !      include 'COMMON.DERIV'
5606 !      include 'COMMON.VAR'
5607 !      include 'COMMON.CHAIN'
5608 !      include 'COMMON.IOUNITS'
5609 !      include 'COMMON.NAMES'
5610 !      include 'COMMON.FFIELD'
5611 !      include 'COMMON.CONTROL'
5612       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5613       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5614       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5615       logical :: lprn=.false., lprn1=.false.
5616 !el local variables
5617       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5618       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5619       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5620 ! local variables for constrains
5621       real(kind=8) :: difi,thetiii
5622        integer itheta
5623
5624       etheta=0.0D0
5625       do i=ithet_start,ithet_end
5626         if (itype(i-1,1).eq.ntyp1) cycle
5627         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5628         if (iabs(itype(i+1,1)).eq.20) iblock=2
5629         if (iabs(itype(i+1,1)).ne.20) iblock=1
5630         dethetai=0.0d0
5631         dephii=0.0d0
5632         dephii1=0.0d0
5633         theti2=0.5d0*theta(i)
5634         ityp2=ithetyp((itype(i-1,1)))
5635         do k=1,nntheterm
5636           coskt(k)=dcos(k*theti2)
5637           sinkt(k)=dsin(k*theti2)
5638         enddo
5639         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5640 #ifdef OSF
5641           phii=phi(i)
5642           if (phii.ne.phii) phii=150.0
5643 #else
5644           phii=phi(i)
5645 #endif
5646           ityp1=ithetyp((itype(i-2,1)))
5647 ! propagation of chirality for glycine type
5648           do k=1,nsingle
5649             cosph1(k)=dcos(k*phii)
5650             sinph1(k)=dsin(k*phii)
5651           enddo
5652         else
5653           phii=0.0d0
5654           ityp1=ithetyp(itype(i-2,1))
5655           do k=1,nsingle
5656             cosph1(k)=0.0d0
5657             sinph1(k)=0.0d0
5658           enddo
5659         endif
5660         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5661 #ifdef OSF
5662           phii1=phi(i+1)
5663           if (phii1.ne.phii1) phii1=150.0
5664           phii1=pinorm(phii1)
5665 #else
5666           phii1=phi(i+1)
5667 #endif
5668           ityp3=ithetyp((itype(i,1)))
5669           do k=1,nsingle
5670             cosph2(k)=dcos(k*phii1)
5671             sinph2(k)=dsin(k*phii1)
5672           enddo
5673         else
5674           phii1=0.0d0
5675           ityp3=ithetyp(itype(i,1))
5676           do k=1,nsingle
5677             cosph2(k)=0.0d0
5678             sinph2(k)=0.0d0
5679           enddo
5680         endif
5681         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5682         do k=1,ndouble
5683           do l=1,k-1
5684             ccl=cosph1(l)*cosph2(k-l)
5685             ssl=sinph1(l)*sinph2(k-l)
5686             scl=sinph1(l)*cosph2(k-l)
5687             csl=cosph1(l)*sinph2(k-l)
5688             cosph1ph2(l,k)=ccl-ssl
5689             cosph1ph2(k,l)=ccl+ssl
5690             sinph1ph2(l,k)=scl+csl
5691             sinph1ph2(k,l)=scl-csl
5692           enddo
5693         enddo
5694         if (lprn) then
5695         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5696           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5697         write (iout,*) "coskt and sinkt"
5698         do k=1,nntheterm
5699           write (iout,*) k,coskt(k),sinkt(k)
5700         enddo
5701         endif
5702         do k=1,ntheterm
5703           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5704           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5705             *coskt(k)
5706           if (lprn) &
5707           write (iout,*) "k",k,&
5708            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5709            " ethetai",ethetai
5710         enddo
5711         if (lprn) then
5712         write (iout,*) "cosph and sinph"
5713         do k=1,nsingle
5714           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5715         enddo
5716         write (iout,*) "cosph1ph2 and sinph2ph2"
5717         do k=2,ndouble
5718           do l=1,k-1
5719             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5720                sinph1ph2(l,k),sinph1ph2(k,l)
5721           enddo
5722         enddo
5723         write(iout,*) "ethetai",ethetai
5724         endif
5725         do m=1,ntheterm2
5726           do k=1,nsingle
5727             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5728                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5729                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5730                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5731             ethetai=ethetai+sinkt(m)*aux
5732             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5733             dephii=dephii+k*sinkt(m)* &
5734                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5735                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5736             dephii1=dephii1+k*sinkt(m)* &
5737                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5738                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5739             if (lprn) &
5740             write (iout,*) "m",m," k",k," bbthet", &
5741                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5742                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5743                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5744                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5745           enddo
5746         enddo
5747         if (lprn) &
5748         write(iout,*) "ethetai",ethetai
5749         do m=1,ntheterm3
5750           do k=2,ndouble
5751             do l=1,k-1
5752               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5753                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5754                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5755                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5756               ethetai=ethetai+sinkt(m)*aux
5757               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5758               dephii=dephii+l*sinkt(m)* &
5759                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5760                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5761                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5762                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5763               dephii1=dephii1+(k-l)*sinkt(m)* &
5764                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5765                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5766                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5767                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5768               if (lprn) then
5769               write (iout,*) "m",m," k",k," l",l," ffthet",&
5770                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5771                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5772                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5773                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5774                   " ethetai",ethetai
5775               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5776                   cosph1ph2(k,l)*sinkt(m),&
5777                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5778               endif
5779             enddo
5780           enddo
5781         enddo
5782 10      continue
5783 !        lprn1=.true.
5784         if (lprn1) &
5785           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5786          i,theta(i)*rad2deg,phii*rad2deg,&
5787          phii1*rad2deg,ethetai
5788 !        lprn1=.false.
5789         etheta=etheta+ethetai
5790         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5791                                     'ebend',i,ethetai
5792         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5793         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5794         gloc(nphi+i-2,icg)=wang*dethetai
5795       enddo
5796 !-----------thete constrains
5797 !      if (tor_mode.ne.2) then
5798       ethetacnstr=0.0d0
5799 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5800       do i=ithetaconstr_start,ithetaconstr_end
5801         itheta=itheta_constr(i)
5802         thetiii=theta(itheta)
5803         difi=pinorm(thetiii-theta_constr0(i))
5804         if (difi.gt.theta_drange(i)) then
5805           difi=difi-theta_drange(i)
5806           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5807           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5808          +for_thet_constr(i)*difi**3
5809         else if (difi.lt.-drange(i)) then
5810           difi=difi+drange(i)
5811           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5812           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5813          +for_thet_constr(i)*difi**3
5814         else
5815           difi=0.0
5816         endif
5817        if (energy_dec) then
5818         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5819          i,itheta,rad2deg*thetiii, &
5820          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5821          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5822          gloc(itheta+nphi-2,icg)
5823         endif
5824       enddo
5825 !      endif
5826
5827       return
5828       end subroutine ebend
5829 #endif
5830 #ifdef CRYST_SC
5831 !-----------------------------------------------------------------------------
5832       subroutine esc(escloc)
5833 ! Calculate the local energy of a side chain and its derivatives in the
5834 ! corresponding virtual-bond valence angles THETA and the spherical angles
5835 ! ALPHA and OMEGA.
5836 !
5837       use comm_sccalc
5838 !      implicit real*8 (a-h,o-z)
5839 !      include 'DIMENSIONS'
5840 !      include 'COMMON.GEO'
5841 !      include 'COMMON.LOCAL'
5842 !      include 'COMMON.VAR'
5843 !      include 'COMMON.INTERACT'
5844 !      include 'COMMON.DERIV'
5845 !      include 'COMMON.CHAIN'
5846 !      include 'COMMON.IOUNITS'
5847 !      include 'COMMON.NAMES'
5848 !      include 'COMMON.FFIELD'
5849 !      include 'COMMON.CONTROL'
5850       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5851          ddersc0,ddummy,xtemp,temp
5852 !el      real(kind=8) :: time11,time12,time112,theti
5853       real(kind=8) :: escloc,delta
5854 !el      integer :: it,nlobit
5855 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5856 !el local variables
5857       integer :: i,k
5858       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5859        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5860       delta=0.02d0*pi
5861       escloc=0.0D0
5862 !     write (iout,'(a)') 'ESC'
5863       do i=loc_start,loc_end
5864         it=itype(i,1)
5865         if (it.eq.ntyp1) cycle
5866         if (it.eq.10) goto 1
5867         nlobit=nlob(iabs(it))
5868 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5869 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5870         theti=theta(i+1)-pipol
5871         x(1)=dtan(theti)
5872         x(2)=alph(i)
5873         x(3)=omeg(i)
5874
5875         if (x(2).gt.pi-delta) then
5876           xtemp(1)=x(1)
5877           xtemp(2)=pi-delta
5878           xtemp(3)=x(3)
5879           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5880           xtemp(2)=pi
5881           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5882           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5883               escloci,dersc(2))
5884           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5885               ddersc0(1),dersc(1))
5886           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5887               ddersc0(3),dersc(3))
5888           xtemp(2)=pi-delta
5889           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5890           xtemp(2)=pi
5891           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5892           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5893                   dersc0(2),esclocbi,dersc02)
5894           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5895                   dersc12,dersc01)
5896           call splinthet(x(2),0.5d0*delta,ss,ssd)
5897           dersc0(1)=dersc01
5898           dersc0(2)=dersc02
5899           dersc0(3)=0.0d0
5900           do k=1,3
5901             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5902           enddo
5903           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5904 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5905 !    &             esclocbi,ss,ssd
5906           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5907 !         escloci=esclocbi
5908 !         write (iout,*) escloci
5909         else if (x(2).lt.delta) then
5910           xtemp(1)=x(1)
5911           xtemp(2)=delta
5912           xtemp(3)=x(3)
5913           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5914           xtemp(2)=0.0d0
5915           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5916           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
5917               escloci,dersc(2))
5918           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5919               ddersc0(1),dersc(1))
5920           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
5921               ddersc0(3),dersc(3))
5922           xtemp(2)=delta
5923           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5924           xtemp(2)=0.0d0
5925           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5926           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
5927                   dersc0(2),esclocbi,dersc02)
5928           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5929                   dersc12,dersc01)
5930           dersc0(1)=dersc01
5931           dersc0(2)=dersc02
5932           dersc0(3)=0.0d0
5933           call splinthet(x(2),0.5d0*delta,ss,ssd)
5934           do k=1,3
5935             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5936           enddo
5937           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5938 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5939 !    &             esclocbi,ss,ssd
5940           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5941 !         write (iout,*) escloci
5942         else
5943           call enesc(x,escloci,dersc,ddummy,.false.)
5944         endif
5945
5946         escloc=escloc+escloci
5947         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5948            'escloc',i,escloci
5949 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5950
5951         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
5952          wscloc*dersc(1)
5953         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5954         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5955     1   continue
5956       enddo
5957       return
5958       end subroutine esc
5959 !-----------------------------------------------------------------------------
5960       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5961
5962       use comm_sccalc
5963 !      implicit real*8 (a-h,o-z)
5964 !      include 'DIMENSIONS'
5965 !      include 'COMMON.GEO'
5966 !      include 'COMMON.LOCAL'
5967 !      include 'COMMON.IOUNITS'
5968 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5969       real(kind=8),dimension(3) :: x,z,dersc,ddersc
5970       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
5971       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
5972       real(kind=8) :: escloci
5973       logical :: mixed
5974 !el local variables
5975       integer :: j,iii,l,k !el,it,nlobit
5976       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
5977 !el       time11,time12,time112
5978 !       write (iout,*) 'it=',it,' nlobit=',nlobit
5979         escloc_i=0.0D0
5980         do j=1,3
5981           dersc(j)=0.0D0
5982           if (mixed) ddersc(j)=0.0d0
5983         enddo
5984         x3=x(3)
5985
5986 ! Because of periodicity of the dependence of the SC energy in omega we have
5987 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5988 ! To avoid underflows, first compute & store the exponents.
5989
5990         do iii=-1,1
5991
5992           x(3)=x3+iii*dwapi
5993
5994           do j=1,nlobit
5995             do k=1,3
5996               z(k)=x(k)-censc(k,j,it)
5997             enddo
5998             do k=1,3
5999               Axk=0.0D0
6000               do l=1,3
6001                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6002               enddo
6003               Ax(k,j,iii)=Axk
6004             enddo
6005             expfac=0.0D0
6006             do k=1,3
6007               expfac=expfac+Ax(k,j,iii)*z(k)
6008             enddo
6009             contr(j,iii)=expfac
6010           enddo ! j
6011
6012         enddo ! iii
6013
6014         x(3)=x3
6015 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6016 ! subsequent NaNs and INFs in energy calculation.
6017 ! Find the largest exponent
6018         emin=contr(1,-1)
6019         do iii=-1,1
6020           do j=1,nlobit
6021             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6022           enddo
6023         enddo
6024         emin=0.5D0*emin
6025 !d      print *,'it=',it,' emin=',emin
6026
6027 ! Compute the contribution to SC energy and derivatives
6028         do iii=-1,1
6029
6030           do j=1,nlobit
6031 #ifdef OSF
6032             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6033             if(adexp.ne.adexp) adexp=1.0
6034             expfac=dexp(adexp)
6035 #else
6036             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6037 #endif
6038 !d          print *,'j=',j,' expfac=',expfac
6039             escloc_i=escloc_i+expfac
6040             do k=1,3
6041               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6042             enddo
6043             if (mixed) then
6044               do k=1,3,2
6045                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6046                   +gaussc(k,2,j,it))*expfac
6047               enddo
6048             endif
6049           enddo
6050
6051         enddo ! iii
6052
6053         dersc(1)=dersc(1)/cos(theti)**2
6054         ddersc(1)=ddersc(1)/cos(theti)**2
6055         ddersc(3)=ddersc(3)
6056
6057         escloci=-(dlog(escloc_i)-emin)
6058         do j=1,3
6059           dersc(j)=dersc(j)/escloc_i
6060         enddo
6061         if (mixed) then
6062           do j=1,3,2
6063             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6064           enddo
6065         endif
6066       return
6067       end subroutine enesc
6068 !-----------------------------------------------------------------------------
6069       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6070
6071       use comm_sccalc
6072 !      implicit real*8 (a-h,o-z)
6073 !      include 'DIMENSIONS'
6074 !      include 'COMMON.GEO'
6075 !      include 'COMMON.LOCAL'
6076 !      include 'COMMON.IOUNITS'
6077 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6078       real(kind=8),dimension(3) :: x,z,dersc
6079       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6080       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6081       real(kind=8) :: escloci,dersc12,emin
6082       logical :: mixed
6083 !el local varables
6084       integer :: j,k,l !el,it,nlobit
6085       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6086
6087       escloc_i=0.0D0
6088
6089       do j=1,3
6090         dersc(j)=0.0D0
6091       enddo
6092
6093       do j=1,nlobit
6094         do k=1,2
6095           z(k)=x(k)-censc(k,j,it)
6096         enddo
6097         z(3)=dwapi
6098         do k=1,3
6099           Axk=0.0D0
6100           do l=1,3
6101             Axk=Axk+gaussc(l,k,j,it)*z(l)
6102           enddo
6103           Ax(k,j)=Axk
6104         enddo
6105         expfac=0.0D0
6106         do k=1,3
6107           expfac=expfac+Ax(k,j)*z(k)
6108         enddo
6109         contr(j)=expfac
6110       enddo ! j
6111
6112 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6113 ! subsequent NaNs and INFs in energy calculation.
6114 ! Find the largest exponent
6115       emin=contr(1)
6116       do j=1,nlobit
6117         if (emin.gt.contr(j)) emin=contr(j)
6118       enddo
6119       emin=0.5D0*emin
6120
6121 ! Compute the contribution to SC energy and derivatives
6122
6123       dersc12=0.0d0
6124       do j=1,nlobit
6125         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6126         escloc_i=escloc_i+expfac
6127         do k=1,2
6128           dersc(k)=dersc(k)+Ax(k,j)*expfac
6129         enddo
6130         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6131                   +gaussc(1,2,j,it))*expfac
6132         dersc(3)=0.0d0
6133       enddo
6134
6135       dersc(1)=dersc(1)/cos(theti)**2
6136       dersc12=dersc12/cos(theti)**2
6137       escloci=-(dlog(escloc_i)-emin)
6138       do j=1,2
6139         dersc(j)=dersc(j)/escloc_i
6140       enddo
6141       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6142       return
6143       end subroutine enesc_bound
6144 #else
6145 !-----------------------------------------------------------------------------
6146       subroutine esc(escloc)
6147 ! Calculate the local energy of a side chain and its derivatives in the
6148 ! corresponding virtual-bond valence angles THETA and the spherical angles
6149 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6150 ! added by Urszula Kozlowska. 07/11/2007
6151 !
6152       use comm_sccalc
6153 !      implicit real*8 (a-h,o-z)
6154 !      include 'DIMENSIONS'
6155 !      include 'COMMON.GEO'
6156 !      include 'COMMON.LOCAL'
6157 !      include 'COMMON.VAR'
6158 !      include 'COMMON.SCROT'
6159 !      include 'COMMON.INTERACT'
6160 !      include 'COMMON.DERIV'
6161 !      include 'COMMON.CHAIN'
6162 !      include 'COMMON.IOUNITS'
6163 !      include 'COMMON.NAMES'
6164 !      include 'COMMON.FFIELD'
6165 !      include 'COMMON.CONTROL'
6166 !      include 'COMMON.VECTORS'
6167       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6168       real(kind=8),dimension(65) :: x
6169       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6170          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6171       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6172       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6173          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6174 !el local variables
6175       integer :: i,j,k !el,it,nlobit
6176       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6177 !el      real(kind=8) :: time11,time12,time112,theti
6178 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6179       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6180                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6181                    sumene1x,sumene2x,sumene3x,sumene4x,&
6182                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6183                    cosfac2xx,sinfac2yy
6184 #ifdef DEBUG
6185       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6186                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6187                    de_dt_num
6188 #endif
6189 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6190
6191       delta=0.02d0*pi
6192       escloc=0.0D0
6193       do i=loc_start,loc_end
6194         if (itype(i,1).eq.ntyp1) cycle
6195         costtab(i+1) =dcos(theta(i+1))
6196         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6197         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6198         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6199         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6200         cosfac=dsqrt(cosfac2)
6201         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6202         sinfac=dsqrt(sinfac2)
6203         it=iabs(itype(i,1))
6204         if (it.eq.10) goto 1
6205 !
6206 !  Compute the axes of tghe local cartesian coordinates system; store in
6207 !   x_prime, y_prime and z_prime
6208 !
6209         do j=1,3
6210           x_prime(j) = 0.00
6211           y_prime(j) = 0.00
6212           z_prime(j) = 0.00
6213         enddo
6214 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6215 !     &   dc_norm(3,i+nres)
6216         do j = 1,3
6217           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6218           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6219         enddo
6220         do j = 1,3
6221           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6222         enddo
6223 !       write (2,*) "i",i
6224 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6225 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6226 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6227 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6228 !      & " xy",scalar(x_prime(1),y_prime(1)),
6229 !      & " xz",scalar(x_prime(1),z_prime(1)),
6230 !      & " yy",scalar(y_prime(1),y_prime(1)),
6231 !      & " yz",scalar(y_prime(1),z_prime(1)),
6232 !      & " zz",scalar(z_prime(1),z_prime(1))
6233 !
6234 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6235 ! to local coordinate system. Store in xx, yy, zz.
6236 !
6237         xx=0.0d0
6238         yy=0.0d0
6239         zz=0.0d0
6240         do j = 1,3
6241           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6242           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6243           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6244         enddo
6245
6246         xxtab(i)=xx
6247         yytab(i)=yy
6248         zztab(i)=zz
6249 !
6250 ! Compute the energy of the ith side cbain
6251 !
6252 !        write (2,*) "xx",xx," yy",yy," zz",zz
6253         it=iabs(itype(i,1))
6254         do j = 1,65
6255           x(j) = sc_parmin(j,it)
6256         enddo
6257 #ifdef CHECK_COORD
6258 !c diagnostics - remove later
6259         xx1 = dcos(alph(2))
6260         yy1 = dsin(alph(2))*dcos(omeg(2))
6261         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6262         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6263           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6264           xx1,yy1,zz1
6265 !,"  --- ", xx_w,yy_w,zz_w
6266 ! end diagnostics
6267 #endif
6268         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6269          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6270          + x(10)*yy*zz
6271         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6272          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6273          + x(20)*yy*zz
6274         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6275          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6276          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6277          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6278          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6279          +x(40)*xx*yy*zz
6280         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6281          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6282          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6283          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6284          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6285          +x(60)*xx*yy*zz
6286         dsc_i   = 0.743d0+x(61)
6287         dp2_i   = 1.9d0+x(62)
6288         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6289                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6290         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6291                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6292         s1=(1+x(63))/(0.1d0 + dscp1)
6293         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6294         s2=(1+x(65))/(0.1d0 + dscp2)
6295         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6296         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6297       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6298 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6299 !     &   sumene4,
6300 !     &   dscp1,dscp2,sumene
6301 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6302         escloc = escloc + sumene
6303 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6304 !     & ,zz,xx,yy
6305 !#define DEBUG
6306 #ifdef DEBUG
6307 !
6308 ! This section to check the numerical derivatives of the energy of ith side
6309 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6310 ! #define DEBUG in the code to turn it on.
6311 !
6312         write (2,*) "sumene               =",sumene
6313         aincr=1.0d-7
6314         xxsave=xx
6315         xx=xx+aincr
6316         write (2,*) xx,yy,zz
6317         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6318         de_dxx_num=(sumenep-sumene)/aincr
6319         xx=xxsave
6320         write (2,*) "xx+ sumene from enesc=",sumenep
6321         yysave=yy
6322         yy=yy+aincr
6323         write (2,*) xx,yy,zz
6324         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6325         de_dyy_num=(sumenep-sumene)/aincr
6326         yy=yysave
6327         write (2,*) "yy+ sumene from enesc=",sumenep
6328         zzsave=zz
6329         zz=zz+aincr
6330         write (2,*) xx,yy,zz
6331         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6332         de_dzz_num=(sumenep-sumene)/aincr
6333         zz=zzsave
6334         write (2,*) "zz+ sumene from enesc=",sumenep
6335         costsave=cost2tab(i+1)
6336         sintsave=sint2tab(i+1)
6337         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6338         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6339         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6340         de_dt_num=(sumenep-sumene)/aincr
6341         write (2,*) " t+ sumene from enesc=",sumenep
6342         cost2tab(i+1)=costsave
6343         sint2tab(i+1)=sintsave
6344 ! End of diagnostics section.
6345 #endif
6346 !
6347 ! Compute the gradient of esc
6348 !
6349 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6350         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6351         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6352         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6353         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6354         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6355         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6356         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6357         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6358         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6359            *(pom_s1/dscp1+pom_s16*dscp1**4)
6360         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6361            *(pom_s2/dscp2+pom_s26*dscp2**4)
6362         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6363         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6364         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6365         +x(40)*yy*zz
6366         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6367         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6368         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6369         +x(60)*yy*zz
6370         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6371               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6372               +(pom1+pom2)*pom_dx
6373 #ifdef DEBUG
6374         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6375 #endif
6376 !
6377         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6378         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6379         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6380         +x(40)*xx*zz
6381         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6382         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6383         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6384         +x(59)*zz**2 +x(60)*xx*zz
6385         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6386               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6387               +(pom1-pom2)*pom_dy
6388 #ifdef DEBUG
6389         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6390 #endif
6391 !
6392         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6393         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6394         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6395         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6396         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6397         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6398         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6399         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6400 #ifdef DEBUG
6401         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6402 #endif
6403 !
6404         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6405         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6406         +pom1*pom_dt1+pom2*pom_dt2
6407 #ifdef DEBUG
6408         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6409 #endif
6410 !
6411 !
6412        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6413        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6414        cosfac2xx=cosfac2*xx
6415        sinfac2yy=sinfac2*yy
6416        do k = 1,3
6417          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6418             vbld_inv(i+1)
6419          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6420             vbld_inv(i)
6421          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6422          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6423 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6424 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6425 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6426 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6427          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6428          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6429          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6430          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6431          dZZ_Ci1(k)=0.0d0
6432          dZZ_Ci(k)=0.0d0
6433          do j=1,3
6434            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6435            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6436            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6437            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6438          enddo
6439
6440          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6441          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6442          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6443          (z_prime(k)-zz*dC_norm(k,i+nres))
6444 !
6445          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6446          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6447        enddo
6448
6449        do k=1,3
6450          dXX_Ctab(k,i)=dXX_Ci(k)
6451          dXX_C1tab(k,i)=dXX_Ci1(k)
6452          dYY_Ctab(k,i)=dYY_Ci(k)
6453          dYY_C1tab(k,i)=dYY_Ci1(k)
6454          dZZ_Ctab(k,i)=dZZ_Ci(k)
6455          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6456          dXX_XYZtab(k,i)=dXX_XYZ(k)
6457          dYY_XYZtab(k,i)=dYY_XYZ(k)
6458          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6459        enddo
6460
6461        do k = 1,3
6462 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6463 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6464 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6465 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6466 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6467 !     &    dt_dci(k)
6468 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6469 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6470          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6471           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6472          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6473           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6474          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6475           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6476        enddo
6477 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6478 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6479
6480 ! to check gradient call subroutine check_grad
6481
6482     1 continue
6483       enddo
6484       return
6485       end subroutine esc
6486 !-----------------------------------------------------------------------------
6487       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6488 !      implicit none
6489       real(kind=8),dimension(65) :: x
6490       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6491         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6492
6493       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6494         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6495         + x(10)*yy*zz
6496       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6497         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6498         + x(20)*yy*zz
6499       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6500         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6501         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6502         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6503         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6504         +x(40)*xx*yy*zz
6505       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6506         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6507         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6508         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6509         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6510         +x(60)*xx*yy*zz
6511       dsc_i   = 0.743d0+x(61)
6512       dp2_i   = 1.9d0+x(62)
6513       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6514                 *(xx*cost2+yy*sint2))
6515       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6516                 *(xx*cost2-yy*sint2))
6517       s1=(1+x(63))/(0.1d0 + dscp1)
6518       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6519       s2=(1+x(65))/(0.1d0 + dscp2)
6520       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6521       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6522        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6523       enesc=sumene
6524       return
6525       end function enesc
6526 #endif
6527 !-----------------------------------------------------------------------------
6528       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6529 !
6530 ! This procedure calculates two-body contact function g(rij) and its derivative:
6531 !
6532 !           eps0ij                                     !       x < -1
6533 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6534 !            0                                         !       x > 1
6535 !
6536 ! where x=(rij-r0ij)/delta
6537 !
6538 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6539 !
6540 !      implicit none
6541       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6542       real(kind=8) :: x,x2,x4,delta
6543 !     delta=0.02D0*r0ij
6544 !      delta=0.2D0*r0ij
6545       x=(rij-r0ij)/delta
6546       if (x.lt.-1.0D0) then
6547         fcont=eps0ij
6548         fprimcont=0.0D0
6549       else if (x.le.1.0D0) then
6550         x2=x*x
6551         x4=x2*x2
6552         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6553         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6554       else
6555         fcont=0.0D0
6556         fprimcont=0.0D0
6557       endif
6558       return
6559       end subroutine gcont
6560 !-----------------------------------------------------------------------------
6561       subroutine splinthet(theti,delta,ss,ssder)
6562 !      implicit real*8 (a-h,o-z)
6563 !      include 'DIMENSIONS'
6564 !      include 'COMMON.VAR'
6565 !      include 'COMMON.GEO'
6566       real(kind=8) :: theti,delta,ss,ssder
6567       real(kind=8) :: thetup,thetlow
6568       thetup=pi-delta
6569       thetlow=delta
6570       if (theti.gt.pipol) then
6571         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6572       else
6573         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6574         ssder=-ssder
6575       endif
6576       return
6577       end subroutine splinthet
6578 !-----------------------------------------------------------------------------
6579       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6580 !      implicit none
6581       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6582       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6583       a1=fprim0*delta/(f1-f0)
6584       a2=3.0d0-2.0d0*a1
6585       a3=a1-2.0d0
6586       ksi=(x-x0)/delta
6587       ksi2=ksi*ksi
6588       ksi3=ksi2*ksi
6589       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6590       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6591       return
6592       end subroutine spline1
6593 !-----------------------------------------------------------------------------
6594       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6595 !      implicit none
6596       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6597       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6598       ksi=(x-x0)/delta
6599       ksi2=ksi*ksi
6600       ksi3=ksi2*ksi
6601       a1=fprim0x*delta
6602       a2=3*(f1x-f0x)-2*fprim0x*delta
6603       a3=fprim0x*delta-2*(f1x-f0x)
6604       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6605       return
6606       end subroutine spline2
6607 !-----------------------------------------------------------------------------
6608 #ifdef CRYST_TOR
6609 !-----------------------------------------------------------------------------
6610       subroutine etor(etors,edihcnstr)
6611 !      implicit real*8 (a-h,o-z)
6612 !      include 'DIMENSIONS'
6613 !      include 'COMMON.VAR'
6614 !      include 'COMMON.GEO'
6615 !      include 'COMMON.LOCAL'
6616 !      include 'COMMON.TORSION'
6617 !      include 'COMMON.INTERACT'
6618 !      include 'COMMON.DERIV'
6619 !      include 'COMMON.CHAIN'
6620 !      include 'COMMON.NAMES'
6621 !      include 'COMMON.IOUNITS'
6622 !      include 'COMMON.FFIELD'
6623 !      include 'COMMON.TORCNSTR'
6624 !      include 'COMMON.CONTROL'
6625       real(kind=8) :: etors,edihcnstr
6626       logical :: lprn
6627 !el local variables
6628       integer :: i,j,
6629       real(kind=8) :: phii,fac,etors_ii
6630
6631 ! Set lprn=.true. for debugging
6632       lprn=.false.
6633 !      lprn=.true.
6634       etors=0.0D0
6635       do i=iphi_start,iphi_end
6636       etors_ii=0.0D0
6637         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6638             .or. itype(i,1).eq.ntyp1) cycle
6639         itori=itortyp(itype(i-2,1))
6640         itori1=itortyp(itype(i-1,1))
6641         phii=phi(i)
6642         gloci=0.0D0
6643 ! Proline-Proline pair is a special case...
6644         if (itori.eq.3 .and. itori1.eq.3) then
6645           if (phii.gt.-dwapi3) then
6646             cosphi=dcos(3*phii)
6647             fac=1.0D0/(1.0D0-cosphi)
6648             etorsi=v1(1,3,3)*fac
6649             etorsi=etorsi+etorsi
6650             etors=etors+etorsi-v1(1,3,3)
6651             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6652             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6653           endif
6654           do j=1,3
6655             v1ij=v1(j+1,itori,itori1)
6656             v2ij=v2(j+1,itori,itori1)
6657             cosphi=dcos(j*phii)
6658             sinphi=dsin(j*phii)
6659             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6660             if (energy_dec) etors_ii=etors_ii+ &
6661                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6662             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6663           enddo
6664         else
6665           do j=1,nterm_old
6666             v1ij=v1(j,itori,itori1)
6667             v2ij=v2(j,itori,itori1)
6668             cosphi=dcos(j*phii)
6669             sinphi=dsin(j*phii)
6670             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6671             if (energy_dec) etors_ii=etors_ii+ &
6672                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6673             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6674           enddo
6675         endif
6676         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6677              'etor',i,etors_ii
6678         if (lprn) &
6679         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6680         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6681         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6682         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6683 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6684       enddo
6685 ! 6/20/98 - dihedral angle constraints
6686       edihcnstr=0.0d0
6687       do i=1,ndih_constr
6688         itori=idih_constr(i)
6689         phii=phi(itori)
6690         difi=phii-phi0(i)
6691         if (difi.gt.drange(i)) then
6692           difi=difi-drange(i)
6693           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6694           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6695         else if (difi.lt.-drange(i)) then
6696           difi=difi+drange(i)
6697           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6698           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6699         endif
6700 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6701 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6702       enddo
6703 !      write (iout,*) 'edihcnstr',edihcnstr
6704       return
6705       end subroutine etor
6706 !-----------------------------------------------------------------------------
6707       subroutine etor_d(etors_d)
6708       real(kind=8) :: etors_d
6709       etors_d=0.0d0
6710       return
6711       end subroutine etor_d
6712 #else
6713 !-----------------------------------------------------------------------------
6714       subroutine etor(etors,edihcnstr)
6715 !      implicit real*8 (a-h,o-z)
6716 !      include 'DIMENSIONS'
6717 !      include 'COMMON.VAR'
6718 !      include 'COMMON.GEO'
6719 !      include 'COMMON.LOCAL'
6720 !      include 'COMMON.TORSION'
6721 !      include 'COMMON.INTERACT'
6722 !      include 'COMMON.DERIV'
6723 !      include 'COMMON.CHAIN'
6724 !      include 'COMMON.NAMES'
6725 !      include 'COMMON.IOUNITS'
6726 !      include 'COMMON.FFIELD'
6727 !      include 'COMMON.TORCNSTR'
6728 !      include 'COMMON.CONTROL'
6729       real(kind=8) :: etors,edihcnstr
6730       logical :: lprn
6731 !el local variables
6732       integer :: i,j,iblock,itori,itori1
6733       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6734                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6735 ! Set lprn=.true. for debugging
6736       lprn=.false.
6737 !     lprn=.true.
6738       etors=0.0D0
6739       do i=iphi_start,iphi_end
6740         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6741              .or. itype(i-3,1).eq.ntyp1 &
6742              .or. itype(i,1).eq.ntyp1) cycle
6743         etors_ii=0.0D0
6744          if (iabs(itype(i,1)).eq.20) then
6745          iblock=2
6746          else
6747          iblock=1
6748          endif
6749         itori=itortyp(itype(i-2,1))
6750         itori1=itortyp(itype(i-1,1))
6751         phii=phi(i)
6752         gloci=0.0D0
6753 ! Regular cosine and sine terms
6754         do j=1,nterm(itori,itori1,iblock)
6755           v1ij=v1(j,itori,itori1,iblock)
6756           v2ij=v2(j,itori,itori1,iblock)
6757           cosphi=dcos(j*phii)
6758           sinphi=dsin(j*phii)
6759           etors=etors+v1ij*cosphi+v2ij*sinphi
6760           if (energy_dec) etors_ii=etors_ii+ &
6761                      v1ij*cosphi+v2ij*sinphi
6762           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6763         enddo
6764 ! Lorentz terms
6765 !                         v1
6766 !  E = SUM ----------------------------------- - v1
6767 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6768 !
6769         cosphi=dcos(0.5d0*phii)
6770         sinphi=dsin(0.5d0*phii)
6771         do j=1,nlor(itori,itori1,iblock)
6772           vl1ij=vlor1(j,itori,itori1)
6773           vl2ij=vlor2(j,itori,itori1)
6774           vl3ij=vlor3(j,itori,itori1)
6775           pom=vl2ij*cosphi+vl3ij*sinphi
6776           pom1=1.0d0/(pom*pom+1.0d0)
6777           etors=etors+vl1ij*pom1
6778           if (energy_dec) etors_ii=etors_ii+ &
6779                      vl1ij*pom1
6780           pom=-pom*pom1*pom1
6781           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6782         enddo
6783 ! Subtract the constant term
6784         etors=etors-v0(itori,itori1,iblock)
6785           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6786                'etor',i,etors_ii-v0(itori,itori1,iblock)
6787         if (lprn) &
6788         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6789         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6790         (v1(j,itori,itori1,iblock),j=1,6),&
6791         (v2(j,itori,itori1,iblock),j=1,6)
6792         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6793 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6794       enddo
6795 ! 6/20/98 - dihedral angle constraints
6796       edihcnstr=0.0d0
6797 !      do i=1,ndih_constr
6798       do i=idihconstr_start,idihconstr_end
6799         itori=idih_constr(i)
6800         phii=phi(itori)
6801         difi=pinorm(phii-phi0(i))
6802         if (difi.gt.drange(i)) then
6803           difi=difi-drange(i)
6804           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6805           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6806         else if (difi.lt.-drange(i)) then
6807           difi=difi+drange(i)
6808           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6809           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6810         else
6811           difi=0.0
6812         endif
6813 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6814 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6815 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6816       enddo
6817 !d       write (iout,*) 'edihcnstr',edihcnstr
6818       return
6819       end subroutine etor
6820 !-----------------------------------------------------------------------------
6821       subroutine etor_d(etors_d)
6822 ! 6/23/01 Compute double torsional energy
6823 !      implicit real*8 (a-h,o-z)
6824 !      include 'DIMENSIONS'
6825 !      include 'COMMON.VAR'
6826 !      include 'COMMON.GEO'
6827 !      include 'COMMON.LOCAL'
6828 !      include 'COMMON.TORSION'
6829 !      include 'COMMON.INTERACT'
6830 !      include 'COMMON.DERIV'
6831 !      include 'COMMON.CHAIN'
6832 !      include 'COMMON.NAMES'
6833 !      include 'COMMON.IOUNITS'
6834 !      include 'COMMON.FFIELD'
6835 !      include 'COMMON.TORCNSTR'
6836       real(kind=8) :: etors_d,etors_d_ii
6837       logical :: lprn
6838 !el local variables
6839       integer :: i,j,k,l,itori,itori1,itori2,iblock
6840       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6841                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6842                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6843                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6844 ! Set lprn=.true. for debugging
6845       lprn=.false.
6846 !     lprn=.true.
6847       etors_d=0.0D0
6848 !      write(iout,*) "a tu??"
6849       do i=iphid_start,iphid_end
6850         etors_d_ii=0.0D0
6851         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6852             .or. itype(i-3,1).eq.ntyp1 &
6853             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6854         itori=itortyp(itype(i-2,1))
6855         itori1=itortyp(itype(i-1,1))
6856         itori2=itortyp(itype(i,1))
6857         phii=phi(i)
6858         phii1=phi(i+1)
6859         gloci1=0.0D0
6860         gloci2=0.0D0
6861         iblock=1
6862         if (iabs(itype(i+1,1)).eq.20) iblock=2
6863
6864 ! Regular cosine and sine terms
6865         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6866           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6867           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6868           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6869           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6870           cosphi1=dcos(j*phii)
6871           sinphi1=dsin(j*phii)
6872           cosphi2=dcos(j*phii1)
6873           sinphi2=dsin(j*phii1)
6874           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6875            v2cij*cosphi2+v2sij*sinphi2
6876           if (energy_dec) etors_d_ii=etors_d_ii+ &
6877            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6878           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6879           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6880         enddo
6881         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6882           do l=1,k-1
6883             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6884             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6885             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6886             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6887             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6888             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6889             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6890             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6891             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6892               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6893             if (energy_dec) etors_d_ii=etors_d_ii+ &
6894               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6895               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6896             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6897               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6898             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6899               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6900           enddo
6901         enddo
6902         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6903                             'etor_d',i,etors_d_ii
6904         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6905         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6906       enddo
6907       return
6908       end subroutine etor_d
6909 #endif
6910 !-----------------------------------------------------------------------------
6911       subroutine eback_sc_corr(esccor)
6912 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
6913 !        conformational states; temporarily implemented as differences
6914 !        between UNRES torsional potentials (dependent on three types of
6915 !        residues) and the torsional potentials dependent on all 20 types
6916 !        of residues computed from AM1  energy surfaces of terminally-blocked
6917 !        amino-acid residues.
6918 !      implicit real*8 (a-h,o-z)
6919 !      include 'DIMENSIONS'
6920 !      include 'COMMON.VAR'
6921 !      include 'COMMON.GEO'
6922 !      include 'COMMON.LOCAL'
6923 !      include 'COMMON.TORSION'
6924 !      include 'COMMON.SCCOR'
6925 !      include 'COMMON.INTERACT'
6926 !      include 'COMMON.DERIV'
6927 !      include 'COMMON.CHAIN'
6928 !      include 'COMMON.NAMES'
6929 !      include 'COMMON.IOUNITS'
6930 !      include 'COMMON.FFIELD'
6931 !      include 'COMMON.CONTROL'
6932       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
6933                    cosphi,sinphi
6934       logical :: lprn
6935       integer :: i,interty,j,isccori,isccori1,intertyp
6936 ! Set lprn=.true. for debugging
6937       lprn=.false.
6938 !      lprn=.true.
6939 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6940       esccor=0.0D0
6941       do i=itau_start,itau_end
6942         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
6943         esccor_ii=0.0D0
6944         isccori=isccortyp(itype(i-2,1))
6945         isccori1=isccortyp(itype(i-1,1))
6946
6947 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6948         phii=phi(i)
6949         do intertyp=1,3 !intertyp
6950          esccor_ii=0.0D0
6951 !c Added 09 May 2012 (Adasko)
6952 !c  Intertyp means interaction type of backbone mainchain correlation:
6953 !   1 = SC...Ca...Ca...Ca
6954 !   2 = Ca...Ca...Ca...SC
6955 !   3 = SC...Ca...Ca...SCi
6956         gloci=0.0D0
6957         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
6958             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
6959             (itype(i-1,1).eq.ntyp1))) &
6960           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
6961            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
6962            .or.(itype(i,1).eq.ntyp1))) &
6963           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
6964             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
6965             (itype(i-3,1).eq.ntyp1)))) cycle
6966         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
6967         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
6968        cycle
6969        do j=1,nterm_sccor(isccori,isccori1)
6970           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6971           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6972           cosphi=dcos(j*tauangle(intertyp,i))
6973           sinphi=dsin(j*tauangle(intertyp,i))
6974           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6975           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6976           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6977         enddo
6978         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
6979                                 'esccor',i,intertyp,esccor_ii
6980 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6981         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6982         if (lprn) &
6983         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6984         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
6985         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
6986         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6987         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6988        enddo !intertyp
6989       enddo
6990
6991       return
6992       end subroutine eback_sc_corr
6993 !-----------------------------------------------------------------------------
6994       subroutine multibody(ecorr)
6995 ! This subroutine calculates multi-body contributions to energy following
6996 ! the idea of Skolnick et al. If side chains I and J make a contact and
6997 ! at the same time side chains I+1 and J+1 make a contact, an extra
6998 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6999 !      implicit real*8 (a-h,o-z)
7000 !      include 'DIMENSIONS'
7001 !      include 'COMMON.IOUNITS'
7002 !      include 'COMMON.DERIV'
7003 !      include 'COMMON.INTERACT'
7004 !      include 'COMMON.CONTACTS'
7005       real(kind=8),dimension(3) :: gx,gx1
7006       logical :: lprn
7007       real(kind=8) :: ecorr
7008       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7009 ! Set lprn=.true. for debugging
7010       lprn=.false.
7011
7012       if (lprn) then
7013         write (iout,'(a)') 'Contact function values:'
7014         do i=nnt,nct-2
7015           write (iout,'(i2,20(1x,i2,f10.5))') &
7016               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7017         enddo
7018       endif
7019       ecorr=0.0D0
7020
7021 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7022 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7023       do i=nnt,nct
7024         do j=1,3
7025           gradcorr(j,i)=0.0D0
7026           gradxorr(j,i)=0.0D0
7027         enddo
7028       enddo
7029       do i=nnt,nct-2
7030
7031         DO ISHIFT = 3,4
7032
7033         i1=i+ishift
7034         num_conti=num_cont(i)
7035         num_conti1=num_cont(i1)
7036         do jj=1,num_conti
7037           j=jcont(jj,i)
7038           do kk=1,num_conti1
7039             j1=jcont(kk,i1)
7040             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7041 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7042 !d   &                   ' ishift=',ishift
7043 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7044 ! The system gains extra energy.
7045               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7046             endif   ! j1==j+-ishift
7047           enddo     ! kk
7048         enddo       ! jj
7049
7050         ENDDO ! ISHIFT
7051
7052       enddo         ! i
7053       return
7054       end subroutine multibody
7055 !-----------------------------------------------------------------------------
7056       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7057 !      implicit real*8 (a-h,o-z)
7058 !      include 'DIMENSIONS'
7059 !      include 'COMMON.IOUNITS'
7060 !      include 'COMMON.DERIV'
7061 !      include 'COMMON.INTERACT'
7062 !      include 'COMMON.CONTACTS'
7063       real(kind=8),dimension(3) :: gx,gx1
7064       logical :: lprn
7065       integer :: i,j,k,l,jj,kk,m,ll
7066       real(kind=8) :: eij,ekl
7067       lprn=.false.
7068       eij=facont(jj,i)
7069       ekl=facont(kk,k)
7070 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7071 ! Calculate the multi-body contribution to energy.
7072 ! Calculate multi-body contributions to the gradient.
7073 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7074 !d   & k,l,(gacont(m,kk,k),m=1,3)
7075       do m=1,3
7076         gx(m) =ekl*gacont(m,jj,i)
7077         gx1(m)=eij*gacont(m,kk,k)
7078         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7079         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7080         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7081         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7082       enddo
7083       do m=i,j-1
7084         do ll=1,3
7085           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7086         enddo
7087       enddo
7088       do m=k,l-1
7089         do ll=1,3
7090           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7091         enddo
7092       enddo
7093       esccorr=-eij*ekl
7094       return
7095       end function esccorr
7096 !-----------------------------------------------------------------------------
7097       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7098 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7099 !      implicit real*8 (a-h,o-z)
7100 !      include 'DIMENSIONS'
7101 !      include 'COMMON.IOUNITS'
7102 #ifdef MPI
7103       include "mpif.h"
7104 !      integer :: maxconts !max_cont=maxconts  =nres/4
7105       integer,parameter :: max_dim=26
7106       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7107       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7108 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7109 !el      common /przechowalnia/ zapas
7110       integer :: status(MPI_STATUS_SIZE)
7111       integer,dimension((nres/4)*2) :: req !maxconts*2
7112       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7113 #endif
7114 !      include 'COMMON.SETUP'
7115 !      include 'COMMON.FFIELD'
7116 !      include 'COMMON.DERIV'
7117 !      include 'COMMON.INTERACT'
7118 !      include 'COMMON.CONTACTS'
7119 !      include 'COMMON.CONTROL'
7120 !      include 'COMMON.LOCAL'
7121       real(kind=8),dimension(3) :: gx,gx1
7122       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7123       logical :: lprn,ldone
7124 !el local variables
7125       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7126               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7127
7128 ! Set lprn=.true. for debugging
7129       lprn=.false.
7130 #ifdef MPI
7131 !      maxconts=nres/4
7132       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7133       n_corr=0
7134       n_corr1=0
7135       if (nfgtasks.le.1) goto 30
7136       if (lprn) then
7137         write (iout,'(a)') 'Contact function values before RECEIVE:'
7138         do i=nnt,nct-2
7139           write (iout,'(2i3,50(1x,i2,f5.2))') &
7140           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7141           j=1,num_cont_hb(i))
7142         enddo
7143       endif
7144       call flush(iout)
7145       do i=1,ntask_cont_from
7146         ncont_recv(i)=0
7147       enddo
7148       do i=1,ntask_cont_to
7149         ncont_sent(i)=0
7150       enddo
7151 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7152 !     & ntask_cont_to
7153 ! Make the list of contacts to send to send to other procesors
7154 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7155 !      call flush(iout)
7156       do i=iturn3_start,iturn3_end
7157 !        write (iout,*) "make contact list turn3",i," num_cont",
7158 !     &    num_cont_hb(i)
7159         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7160       enddo
7161       do i=iturn4_start,iturn4_end
7162 !        write (iout,*) "make contact list turn4",i," num_cont",
7163 !     &   num_cont_hb(i)
7164         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7165       enddo
7166       do ii=1,nat_sent
7167         i=iat_sent(ii)
7168 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7169 !     &    num_cont_hb(i)
7170         do j=1,num_cont_hb(i)
7171         do k=1,4
7172           jjc=jcont_hb(j,i)
7173           iproc=iint_sent_local(k,jjc,ii)
7174 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7175           if (iproc.gt.0) then
7176             ncont_sent(iproc)=ncont_sent(iproc)+1
7177             nn=ncont_sent(iproc)
7178             zapas(1,nn,iproc)=i
7179             zapas(2,nn,iproc)=jjc
7180             zapas(3,nn,iproc)=facont_hb(j,i)
7181             zapas(4,nn,iproc)=ees0p(j,i)
7182             zapas(5,nn,iproc)=ees0m(j,i)
7183             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7184             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7185             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7186             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7187             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7188             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7189             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7190             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7191             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7192             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7193             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7194             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7195             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7196             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7197             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7198             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7199             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7200             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7201             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7202             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7203             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7204           endif
7205         enddo
7206         enddo
7207       enddo
7208       if (lprn) then
7209       write (iout,*) &
7210         "Numbers of contacts to be sent to other processors",&
7211         (ncont_sent(i),i=1,ntask_cont_to)
7212       write (iout,*) "Contacts sent"
7213       do ii=1,ntask_cont_to
7214         nn=ncont_sent(ii)
7215         iproc=itask_cont_to(ii)
7216         write (iout,*) nn," contacts to processor",iproc,&
7217          " of CONT_TO_COMM group"
7218         do i=1,nn
7219           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7220         enddo
7221       enddo
7222       call flush(iout)
7223       endif
7224       CorrelType=477
7225       CorrelID=fg_rank+1
7226       CorrelType1=478
7227       CorrelID1=nfgtasks+fg_rank+1
7228       ireq=0
7229 ! Receive the numbers of needed contacts from other processors
7230       do ii=1,ntask_cont_from
7231         iproc=itask_cont_from(ii)
7232         ireq=ireq+1
7233         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7234           FG_COMM,req(ireq),IERR)
7235       enddo
7236 !      write (iout,*) "IRECV ended"
7237 !      call flush(iout)
7238 ! Send the number of contacts needed by other processors
7239       do ii=1,ntask_cont_to
7240         iproc=itask_cont_to(ii)
7241         ireq=ireq+1
7242         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7243           FG_COMM,req(ireq),IERR)
7244       enddo
7245 !      write (iout,*) "ISEND ended"
7246 !      write (iout,*) "number of requests (nn)",ireq
7247       call flush(iout)
7248       if (ireq.gt.0) &
7249         call MPI_Waitall(ireq,req,status_array,ierr)
7250 !      write (iout,*)
7251 !     &  "Numbers of contacts to be received from other processors",
7252 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7253 !      call flush(iout)
7254 ! Receive contacts
7255       ireq=0
7256       do ii=1,ntask_cont_from
7257         iproc=itask_cont_from(ii)
7258         nn=ncont_recv(ii)
7259 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7260 !     &   " of CONT_TO_COMM group"
7261         call flush(iout)
7262         if (nn.gt.0) then
7263           ireq=ireq+1
7264           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7265           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7266 !          write (iout,*) "ireq,req",ireq,req(ireq)
7267         endif
7268       enddo
7269 ! Send the contacts to processors that need them
7270       do ii=1,ntask_cont_to
7271         iproc=itask_cont_to(ii)
7272         nn=ncont_sent(ii)
7273 !        write (iout,*) nn," contacts to processor",iproc,
7274 !     &   " of CONT_TO_COMM group"
7275         if (nn.gt.0) then
7276           ireq=ireq+1
7277           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7278             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7279 !          write (iout,*) "ireq,req",ireq,req(ireq)
7280 !          do i=1,nn
7281 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7282 !          enddo
7283         endif
7284       enddo
7285 !      write (iout,*) "number of requests (contacts)",ireq
7286 !      write (iout,*) "req",(req(i),i=1,4)
7287 !      call flush(iout)
7288       if (ireq.gt.0) &
7289        call MPI_Waitall(ireq,req,status_array,ierr)
7290       do iii=1,ntask_cont_from
7291         iproc=itask_cont_from(iii)
7292         nn=ncont_recv(iii)
7293         if (lprn) then
7294         write (iout,*) "Received",nn," contacts from processor",iproc,&
7295          " of CONT_FROM_COMM group"
7296         call flush(iout)
7297         do i=1,nn
7298           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7299         enddo
7300         call flush(iout)
7301         endif
7302         do i=1,nn
7303           ii=zapas_recv(1,i,iii)
7304 ! Flag the received contacts to prevent double-counting
7305           jj=-zapas_recv(2,i,iii)
7306 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7307 !          call flush(iout)
7308           nnn=num_cont_hb(ii)+1
7309           num_cont_hb(ii)=nnn
7310           jcont_hb(nnn,ii)=jj
7311           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7312           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7313           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7314           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7315           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7316           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7317           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7318           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7319           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7320           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7321           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7322           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7323           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7324           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7325           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7326           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7327           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7328           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7329           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7330           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7331           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7332           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7333           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7334           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7335         enddo
7336       enddo
7337       call flush(iout)
7338       if (lprn) then
7339         write (iout,'(a)') 'Contact function values after receive:'
7340         do i=nnt,nct-2
7341           write (iout,'(2i3,50(1x,i3,f5.2))') &
7342           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7343           j=1,num_cont_hb(i))
7344         enddo
7345         call flush(iout)
7346       endif
7347    30 continue
7348 #endif
7349       if (lprn) then
7350         write (iout,'(a)') 'Contact function values:'
7351         do i=nnt,nct-2
7352           write (iout,'(2i3,50(1x,i3,f5.2))') &
7353           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7354           j=1,num_cont_hb(i))
7355         enddo
7356       endif
7357       ecorr=0.0D0
7358
7359 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7360 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7361 ! Remove the loop below after debugging !!!
7362       do i=nnt,nct
7363         do j=1,3
7364           gradcorr(j,i)=0.0D0
7365           gradxorr(j,i)=0.0D0
7366         enddo
7367       enddo
7368 ! Calculate the local-electrostatic correlation terms
7369       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7370         i1=i+1
7371         num_conti=num_cont_hb(i)
7372         num_conti1=num_cont_hb(i+1)
7373         do jj=1,num_conti
7374           j=jcont_hb(jj,i)
7375           jp=iabs(j)
7376           do kk=1,num_conti1
7377             j1=jcont_hb(kk,i1)
7378             jp1=iabs(j1)
7379 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7380 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7381             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7382                 .or. j.lt.0 .and. j1.gt.0) .and. &
7383                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7384 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7385 ! The system gains extra energy.
7386               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7387               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7388                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7389               n_corr=n_corr+1
7390             else if (j1.eq.j) then
7391 ! Contacts I-J and I-(J+1) occur simultaneously.
7392 ! The system loses extra energy.
7393 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7394             endif
7395           enddo ! kk
7396           do kk=1,num_conti
7397             j1=jcont_hb(kk,i)
7398 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7399 !    &         ' jj=',jj,' kk=',kk
7400             if (j1.eq.j+1) then
7401 ! Contacts I-J and (I+1)-J occur simultaneously.
7402 ! The system loses extra energy.
7403 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7404             endif ! j1==j+1
7405           enddo ! kk
7406         enddo ! jj
7407       enddo ! i
7408       return
7409       end subroutine multibody_hb
7410 !-----------------------------------------------------------------------------
7411       subroutine add_hb_contact(ii,jj,itask)
7412 !      implicit real*8 (a-h,o-z)
7413 !      include "DIMENSIONS"
7414 !      include "COMMON.IOUNITS"
7415 !      include "COMMON.CONTACTS"
7416 !      integer,parameter :: maxconts=nres/4
7417       integer,parameter :: max_dim=26
7418       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7419 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7420 !      common /przechowalnia/ zapas
7421       integer :: i,j,ii,jj,iproc,nn,jjc
7422       integer,dimension(4) :: itask
7423 !      write (iout,*) "itask",itask
7424       do i=1,2
7425         iproc=itask(i)
7426         if (iproc.gt.0) then
7427           do j=1,num_cont_hb(ii)
7428             jjc=jcont_hb(j,ii)
7429 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7430             if (jjc.eq.jj) then
7431               ncont_sent(iproc)=ncont_sent(iproc)+1
7432               nn=ncont_sent(iproc)
7433               zapas(1,nn,iproc)=ii
7434               zapas(2,nn,iproc)=jjc
7435               zapas(3,nn,iproc)=facont_hb(j,ii)
7436               zapas(4,nn,iproc)=ees0p(j,ii)
7437               zapas(5,nn,iproc)=ees0m(j,ii)
7438               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7439               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7440               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7441               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7442               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7443               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7444               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7445               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7446               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7447               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7448               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7449               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7450               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7451               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7452               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7453               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7454               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7455               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7456               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7457               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7458               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7459               exit
7460             endif
7461           enddo
7462         endif
7463       enddo
7464       return
7465       end subroutine add_hb_contact
7466 !-----------------------------------------------------------------------------
7467       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7468 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7469 !      implicit real*8 (a-h,o-z)
7470 !      include 'DIMENSIONS'
7471 !      include 'COMMON.IOUNITS'
7472       integer,parameter :: max_dim=70
7473 #ifdef MPI
7474       include "mpif.h"
7475 !      integer :: maxconts !max_cont=maxconts=nres/4
7476       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7477       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7478 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7479 !      common /przechowalnia/ zapas
7480       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7481         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7482         ierr,iii,nnn
7483 #endif
7484 !      include 'COMMON.SETUP'
7485 !      include 'COMMON.FFIELD'
7486 !      include 'COMMON.DERIV'
7487 !      include 'COMMON.LOCAL'
7488 !      include 'COMMON.INTERACT'
7489 !      include 'COMMON.CONTACTS'
7490 !      include 'COMMON.CHAIN'
7491 !      include 'COMMON.CONTROL'
7492       real(kind=8),dimension(3) :: gx,gx1
7493       integer,dimension(nres) :: num_cont_hb_old
7494       logical :: lprn,ldone
7495 !EL      double precision eello4,eello5,eelo6,eello_turn6
7496 !EL      external eello4,eello5,eello6,eello_turn6
7497 !el local variables
7498       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7499               j1,jp1,i1,num_conti1
7500       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7501       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7502
7503 ! Set lprn=.true. for debugging
7504       lprn=.false.
7505       eturn6=0.0d0
7506 #ifdef MPI
7507 !      maxconts=nres/4
7508       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7509       do i=1,nres
7510         num_cont_hb_old(i)=num_cont_hb(i)
7511       enddo
7512       n_corr=0
7513       n_corr1=0
7514       if (nfgtasks.le.1) goto 30
7515       if (lprn) then
7516         write (iout,'(a)') 'Contact function values before RECEIVE:'
7517         do i=nnt,nct-2
7518           write (iout,'(2i3,50(1x,i2,f5.2))') &
7519           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7520           j=1,num_cont_hb(i))
7521         enddo
7522       endif
7523       call flush(iout)
7524       do i=1,ntask_cont_from
7525         ncont_recv(i)=0
7526       enddo
7527       do i=1,ntask_cont_to
7528         ncont_sent(i)=0
7529       enddo
7530 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7531 !     & ntask_cont_to
7532 ! Make the list of contacts to send to send to other procesors
7533       do i=iturn3_start,iturn3_end
7534 !        write (iout,*) "make contact list turn3",i," num_cont",
7535 !     &    num_cont_hb(i)
7536         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7537       enddo
7538       do i=iturn4_start,iturn4_end
7539 !        write (iout,*) "make contact list turn4",i," num_cont",
7540 !     &   num_cont_hb(i)
7541         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7542       enddo
7543       do ii=1,nat_sent
7544         i=iat_sent(ii)
7545 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7546 !     &    num_cont_hb(i)
7547         do j=1,num_cont_hb(i)
7548         do k=1,4
7549           jjc=jcont_hb(j,i)
7550           iproc=iint_sent_local(k,jjc,ii)
7551 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7552           if (iproc.ne.0) then
7553             ncont_sent(iproc)=ncont_sent(iproc)+1
7554             nn=ncont_sent(iproc)
7555             zapas(1,nn,iproc)=i
7556             zapas(2,nn,iproc)=jjc
7557             zapas(3,nn,iproc)=d_cont(j,i)
7558             ind=3
7559             do kk=1,3
7560               ind=ind+1
7561               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7562             enddo
7563             do kk=1,2
7564               do ll=1,2
7565                 ind=ind+1
7566                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7567               enddo
7568             enddo
7569             do jj=1,5
7570               do kk=1,3
7571                 do ll=1,2
7572                   do mm=1,2
7573                     ind=ind+1
7574                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7575                   enddo
7576                 enddo
7577               enddo
7578             enddo
7579           endif
7580         enddo
7581         enddo
7582       enddo
7583       if (lprn) then
7584       write (iout,*) &
7585         "Numbers of contacts to be sent to other processors",&
7586         (ncont_sent(i),i=1,ntask_cont_to)
7587       write (iout,*) "Contacts sent"
7588       do ii=1,ntask_cont_to
7589         nn=ncont_sent(ii)
7590         iproc=itask_cont_to(ii)
7591         write (iout,*) nn," contacts to processor",iproc,&
7592          " of CONT_TO_COMM group"
7593         do i=1,nn
7594           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7595         enddo
7596       enddo
7597       call flush(iout)
7598       endif
7599       CorrelType=477
7600       CorrelID=fg_rank+1
7601       CorrelType1=478
7602       CorrelID1=nfgtasks+fg_rank+1
7603       ireq=0
7604 ! Receive the numbers of needed contacts from other processors
7605       do ii=1,ntask_cont_from
7606         iproc=itask_cont_from(ii)
7607         ireq=ireq+1
7608         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7609           FG_COMM,req(ireq),IERR)
7610       enddo
7611 !      write (iout,*) "IRECV ended"
7612 !      call flush(iout)
7613 ! Send the number of contacts needed by other processors
7614       do ii=1,ntask_cont_to
7615         iproc=itask_cont_to(ii)
7616         ireq=ireq+1
7617         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7618           FG_COMM,req(ireq),IERR)
7619       enddo
7620 !      write (iout,*) "ISEND ended"
7621 !      write (iout,*) "number of requests (nn)",ireq
7622       call flush(iout)
7623       if (ireq.gt.0) &
7624         call MPI_Waitall(ireq,req,status_array,ierr)
7625 !      write (iout,*)
7626 !     &  "Numbers of contacts to be received from other processors",
7627 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7628 !      call flush(iout)
7629 ! Receive contacts
7630       ireq=0
7631       do ii=1,ntask_cont_from
7632         iproc=itask_cont_from(ii)
7633         nn=ncont_recv(ii)
7634 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7635 !     &   " of CONT_TO_COMM group"
7636         call flush(iout)
7637         if (nn.gt.0) then
7638           ireq=ireq+1
7639           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7640           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7641 !          write (iout,*) "ireq,req",ireq,req(ireq)
7642         endif
7643       enddo
7644 ! Send the contacts to processors that need them
7645       do ii=1,ntask_cont_to
7646         iproc=itask_cont_to(ii)
7647         nn=ncont_sent(ii)
7648 !        write (iout,*) nn," contacts to processor",iproc,
7649 !     &   " of CONT_TO_COMM group"
7650         if (nn.gt.0) then
7651           ireq=ireq+1
7652           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7653             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7654 !          write (iout,*) "ireq,req",ireq,req(ireq)
7655 !          do i=1,nn
7656 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7657 !          enddo
7658         endif
7659       enddo
7660 !      write (iout,*) "number of requests (contacts)",ireq
7661 !      write (iout,*) "req",(req(i),i=1,4)
7662 !      call flush(iout)
7663       if (ireq.gt.0) &
7664        call MPI_Waitall(ireq,req,status_array,ierr)
7665       do iii=1,ntask_cont_from
7666         iproc=itask_cont_from(iii)
7667         nn=ncont_recv(iii)
7668         if (lprn) then
7669         write (iout,*) "Received",nn," contacts from processor",iproc,&
7670          " of CONT_FROM_COMM group"
7671         call flush(iout)
7672         do i=1,nn
7673           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7674         enddo
7675         call flush(iout)
7676         endif
7677         do i=1,nn
7678           ii=zapas_recv(1,i,iii)
7679 ! Flag the received contacts to prevent double-counting
7680           jj=-zapas_recv(2,i,iii)
7681 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7682 !          call flush(iout)
7683           nnn=num_cont_hb(ii)+1
7684           num_cont_hb(ii)=nnn
7685           jcont_hb(nnn,ii)=jj
7686           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7687           ind=3
7688           do kk=1,3
7689             ind=ind+1
7690             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7691           enddo
7692           do kk=1,2
7693             do ll=1,2
7694               ind=ind+1
7695               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7696             enddo
7697           enddo
7698           do jj=1,5
7699             do kk=1,3
7700               do ll=1,2
7701                 do mm=1,2
7702                   ind=ind+1
7703                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7704                 enddo
7705               enddo
7706             enddo
7707           enddo
7708         enddo
7709       enddo
7710       call flush(iout)
7711       if (lprn) then
7712         write (iout,'(a)') 'Contact function values after receive:'
7713         do i=nnt,nct-2
7714           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7715           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7716           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7717         enddo
7718         call flush(iout)
7719       endif
7720    30 continue
7721 #endif
7722       if (lprn) then
7723         write (iout,'(a)') 'Contact function values:'
7724         do i=nnt,nct-2
7725           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7726           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7727           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7728         enddo
7729       endif
7730       ecorr=0.0D0
7731       ecorr5=0.0d0
7732       ecorr6=0.0d0
7733
7734 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7735 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7736 ! Remove the loop below after debugging !!!
7737       do i=nnt,nct
7738         do j=1,3
7739           gradcorr(j,i)=0.0D0
7740           gradxorr(j,i)=0.0D0
7741         enddo
7742       enddo
7743 ! Calculate the dipole-dipole interaction energies
7744       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7745       do i=iatel_s,iatel_e+1
7746         num_conti=num_cont_hb(i)
7747         do jj=1,num_conti
7748           j=jcont_hb(jj,i)
7749 #ifdef MOMENT
7750           call dipole(i,j,jj)
7751 #endif
7752         enddo
7753       enddo
7754       endif
7755 ! Calculate the local-electrostatic correlation terms
7756 !                write (iout,*) "gradcorr5 in eello5 before loop"
7757 !                do iii=1,nres
7758 !                  write (iout,'(i5,3f10.5)')
7759 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7760 !                enddo
7761       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7762 !        write (iout,*) "corr loop i",i
7763         i1=i+1
7764         num_conti=num_cont_hb(i)
7765         num_conti1=num_cont_hb(i+1)
7766         do jj=1,num_conti
7767           j=jcont_hb(jj,i)
7768           jp=iabs(j)
7769           do kk=1,num_conti1
7770             j1=jcont_hb(kk,i1)
7771             jp1=iabs(j1)
7772 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7773 !     &         ' jj=',jj,' kk=',kk
7774 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7775             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7776                 .or. j.lt.0 .and. j1.gt.0) .and. &
7777                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7778 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7779 ! The system gains extra energy.
7780               n_corr=n_corr+1
7781               sqd1=dsqrt(d_cont(jj,i))
7782               sqd2=dsqrt(d_cont(kk,i1))
7783               sred_geom = sqd1*sqd2
7784               IF (sred_geom.lt.cutoff_corr) THEN
7785                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7786                   ekont,fprimcont)
7787 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7788 !d     &         ' jj=',jj,' kk=',kk
7789                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7790                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7791                 do l=1,3
7792                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7793                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7794                 enddo
7795                 n_corr1=n_corr1+1
7796 !d               write (iout,*) 'sred_geom=',sred_geom,
7797 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7798 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7799 !d               write (iout,*) "g_contij",g_contij
7800 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7801 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7802                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7803                 if (wcorr4.gt.0.0d0) &
7804                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7805                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7806                        write (iout,'(a6,4i5,0pf7.3)') &
7807                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7808 !                write (iout,*) "gradcorr5 before eello5"
7809 !                do iii=1,nres
7810 !                  write (iout,'(i5,3f10.5)')
7811 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7812 !                enddo
7813                 if (wcorr5.gt.0.0d0) &
7814                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7815 !                write (iout,*) "gradcorr5 after eello5"
7816 !                do iii=1,nres
7817 !                  write (iout,'(i5,3f10.5)')
7818 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7819 !                enddo
7820                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7821                        write (iout,'(a6,4i5,0pf7.3)') &
7822                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7823 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7824 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7825                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7826                      .or. wturn6.eq.0.0d0))then
7827 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7828                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7829                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7830                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7831 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7832 !d     &            'ecorr6=',ecorr6
7833 !d                write (iout,'(4e15.5)') sred_geom,
7834 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7835 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7836 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7837                 else if (wturn6.gt.0.0d0 &
7838                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7839 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7840                   eturn6=eturn6+eello_turn6(i,jj,kk)
7841                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7842                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7843 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7844                 endif
7845               ENDIF
7846 1111          continue
7847             endif
7848           enddo ! kk
7849         enddo ! jj
7850       enddo ! i
7851       do i=1,nres
7852         num_cont_hb(i)=num_cont_hb_old(i)
7853       enddo
7854 !                write (iout,*) "gradcorr5 in eello5"
7855 !                do iii=1,nres
7856 !                  write (iout,'(i5,3f10.5)')
7857 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7858 !                enddo
7859       return
7860       end subroutine multibody_eello
7861 !-----------------------------------------------------------------------------
7862       subroutine add_hb_contact_eello(ii,jj,itask)
7863 !      implicit real*8 (a-h,o-z)
7864 !      include "DIMENSIONS"
7865 !      include "COMMON.IOUNITS"
7866 !      include "COMMON.CONTACTS"
7867 !      integer,parameter :: maxconts=nres/4
7868       integer,parameter :: max_dim=70
7869       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7870 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7871 !      common /przechowalnia/ zapas
7872
7873       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7874       integer,dimension(4) ::itask
7875 !      write (iout,*) "itask",itask
7876       do i=1,2
7877         iproc=itask(i)
7878         if (iproc.gt.0) then
7879           do j=1,num_cont_hb(ii)
7880             jjc=jcont_hb(j,ii)
7881 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7882             if (jjc.eq.jj) then
7883               ncont_sent(iproc)=ncont_sent(iproc)+1
7884               nn=ncont_sent(iproc)
7885               zapas(1,nn,iproc)=ii
7886               zapas(2,nn,iproc)=jjc
7887               zapas(3,nn,iproc)=d_cont(j,ii)
7888               ind=3
7889               do kk=1,3
7890                 ind=ind+1
7891                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7892               enddo
7893               do kk=1,2
7894                 do ll=1,2
7895                   ind=ind+1
7896                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7897                 enddo
7898               enddo
7899               do jj=1,5
7900                 do kk=1,3
7901                   do ll=1,2
7902                     do mm=1,2
7903                       ind=ind+1
7904                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7905                     enddo
7906                   enddo
7907                 enddo
7908               enddo
7909               exit
7910             endif
7911           enddo
7912         endif
7913       enddo
7914       return
7915       end subroutine add_hb_contact_eello
7916 !-----------------------------------------------------------------------------
7917       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7918 !      implicit real*8 (a-h,o-z)
7919 !      include 'DIMENSIONS'
7920 !      include 'COMMON.IOUNITS'
7921 !      include 'COMMON.DERIV'
7922 !      include 'COMMON.INTERACT'
7923 !      include 'COMMON.CONTACTS'
7924       real(kind=8),dimension(3) :: gx,gx1
7925       logical :: lprn
7926 !el local variables
7927       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
7928       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
7929                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
7930                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
7931                    rlocshield
7932
7933       lprn=.false.
7934       eij=facont_hb(jj,i)
7935       ekl=facont_hb(kk,k)
7936       ees0pij=ees0p(jj,i)
7937       ees0pkl=ees0p(kk,k)
7938       ees0mij=ees0m(jj,i)
7939       ees0mkl=ees0m(kk,k)
7940       ekont=eij*ekl
7941       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7942 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7943 ! Following 4 lines for diagnostics.
7944 !d    ees0pkl=0.0D0
7945 !d    ees0pij=1.0D0
7946 !d    ees0mkl=0.0D0
7947 !d    ees0mij=1.0D0
7948 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7949 !     & 'Contacts ',i,j,
7950 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7951 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7952 !     & 'gradcorr_long'
7953 ! Calculate the multi-body contribution to energy.
7954 !      ecorr=ecorr+ekont*ees
7955 ! Calculate multi-body contributions to the gradient.
7956       coeffpees0pij=coeffp*ees0pij
7957       coeffmees0mij=coeffm*ees0mij
7958       coeffpees0pkl=coeffp*ees0pkl
7959       coeffmees0mkl=coeffm*ees0mkl
7960       do ll=1,3
7961 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7962         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
7963         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
7964         coeffmees0mkl*gacontm_hb1(ll,jj,i))
7965         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
7966         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
7967         coeffmees0mkl*gacontm_hb2(ll,jj,i))
7968 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7969         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
7970         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
7971         coeffmees0mij*gacontm_hb1(ll,kk,k))
7972         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
7973         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
7974         coeffmees0mij*gacontm_hb2(ll,kk,k))
7975         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
7976            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
7977            coeffmees0mkl*gacontm_hb3(ll,jj,i))
7978         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7979         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7980         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
7981            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
7982            coeffmees0mij*gacontm_hb3(ll,kk,k))
7983         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7984         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7985 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7986       enddo
7987 !      write (iout,*)
7988 !grad      do m=i+1,j-1
7989 !grad        do ll=1,3
7990 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7991 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7992 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7993 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7994 !grad        enddo
7995 !grad      enddo
7996 !grad      do m=k+1,l-1
7997 !grad        do ll=1,3
7998 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7999 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8000 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8001 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8002 !grad        enddo
8003 !grad      enddo
8004 !      write (iout,*) "ehbcorr",ekont*ees
8005       ehbcorr=ekont*ees
8006       if (shield_mode.gt.0) then
8007        j=ees0plist(jj,i)
8008        l=ees0plist(kk,k)
8009 !C        print *,i,j,fac_shield(i),fac_shield(j),
8010 !C     &fac_shield(k),fac_shield(l)
8011         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8012            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8013           do ilist=1,ishield_list(i)
8014            iresshield=shield_list(ilist,i)
8015            do m=1,3
8016            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8017            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8018                    rlocshield  &
8019             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8020             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8021             +rlocshield
8022            enddo
8023           enddo
8024           do ilist=1,ishield_list(j)
8025            iresshield=shield_list(ilist,j)
8026            do m=1,3
8027            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8028            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8029                    rlocshield &
8030             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8031            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8032             +rlocshield
8033            enddo
8034           enddo
8035
8036           do ilist=1,ishield_list(k)
8037            iresshield=shield_list(ilist,k)
8038            do m=1,3
8039            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8040            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8041                    rlocshield &
8042             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8043            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8044             +rlocshield
8045            enddo
8046           enddo
8047           do ilist=1,ishield_list(l)
8048            iresshield=shield_list(ilist,l)
8049            do m=1,3
8050            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8051            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8052                    rlocshield &
8053             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8054            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8055             +rlocshield
8056            enddo
8057           enddo
8058           do m=1,3
8059             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8060                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8061             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8062                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8063             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8064                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8065             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8066                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8067
8068             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8069                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8070             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8071                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8072             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8073                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8074             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8075                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8076
8077            enddo
8078       endif
8079       endif
8080       return
8081       end function ehbcorr
8082 #ifdef MOMENT
8083 !-----------------------------------------------------------------------------
8084       subroutine dipole(i,j,jj)
8085 !      implicit real*8 (a-h,o-z)
8086 !      include 'DIMENSIONS'
8087 !      include 'COMMON.IOUNITS'
8088 !      include 'COMMON.CHAIN'
8089 !      include 'COMMON.FFIELD'
8090 !      include 'COMMON.DERIV'
8091 !      include 'COMMON.INTERACT'
8092 !      include 'COMMON.CONTACTS'
8093 !      include 'COMMON.TORSION'
8094 !      include 'COMMON.VAR'
8095 !      include 'COMMON.GEO'
8096       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8097       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8098       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8099
8100       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8101       allocate(dipderx(3,5,4,maxconts,nres))
8102 !
8103
8104       iti1 = itortyp(itype(i+1,1))
8105       if (j.lt.nres-1) then
8106         itj1 = itortyp(itype(j+1,1))
8107       else
8108         itj1=ntortyp+1
8109       endif
8110       do iii=1,2
8111         dipi(iii,1)=Ub2(iii,i)
8112         dipderi(iii)=Ub2der(iii,i)
8113         dipi(iii,2)=b1(iii,iti1)
8114         dipj(iii,1)=Ub2(iii,j)
8115         dipderj(iii)=Ub2der(iii,j)
8116         dipj(iii,2)=b1(iii,itj1)
8117       enddo
8118       kkk=0
8119       do iii=1,2
8120         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8121         do jjj=1,2
8122           kkk=kkk+1
8123           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8124         enddo
8125       enddo
8126       do kkk=1,5
8127         do lll=1,3
8128           mmm=0
8129           do iii=1,2
8130             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8131               auxvec(1))
8132             do jjj=1,2
8133               mmm=mmm+1
8134               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8135             enddo
8136           enddo
8137         enddo
8138       enddo
8139       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8140       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8141       do iii=1,2
8142         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8143       enddo
8144       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8145       do iii=1,2
8146         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8147       enddo
8148       return
8149       end subroutine dipole
8150 #endif
8151 !-----------------------------------------------------------------------------
8152       subroutine calc_eello(i,j,k,l,jj,kk)
8153 !
8154 ! This subroutine computes matrices and vectors needed to calculate
8155 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8156 !
8157       use comm_kut
8158 !      implicit real*8 (a-h,o-z)
8159 !      include 'DIMENSIONS'
8160 !      include 'COMMON.IOUNITS'
8161 !      include 'COMMON.CHAIN'
8162 !      include 'COMMON.DERIV'
8163 !      include 'COMMON.INTERACT'
8164 !      include 'COMMON.CONTACTS'
8165 !      include 'COMMON.TORSION'
8166 !      include 'COMMON.VAR'
8167 !      include 'COMMON.GEO'
8168 !      include 'COMMON.FFIELD'
8169       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8170       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8171       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8172               itj1
8173 !el      logical :: lprn
8174 !el      common /kutas/ lprn
8175 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8176 !d     & ' jj=',jj,' kk=',kk
8177 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8178 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8179 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8180       do iii=1,2
8181         do jjj=1,2
8182           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8183           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8184         enddo
8185       enddo
8186       call transpose2(aa1(1,1),aa1t(1,1))
8187       call transpose2(aa2(1,1),aa2t(1,1))
8188       do kkk=1,5
8189         do lll=1,3
8190           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8191             aa1tder(1,1,lll,kkk))
8192           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8193             aa2tder(1,1,lll,kkk))
8194         enddo
8195       enddo
8196       if (l.eq.j+1) then
8197 ! parallel orientation of the two CA-CA-CA frames.
8198         if (i.gt.1) then
8199           iti=itortyp(itype(i,1))
8200         else
8201           iti=ntortyp+1
8202         endif
8203         itk1=itortyp(itype(k+1,1))
8204         itj=itortyp(itype(j,1))
8205         if (l.lt.nres-1) then
8206           itl1=itortyp(itype(l+1,1))
8207         else
8208           itl1=ntortyp+1
8209         endif
8210 ! A1 kernel(j+1) A2T
8211 !d        do iii=1,2
8212 !d          write (iout,'(3f10.5,5x,3f10.5)')
8213 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8214 !d        enddo
8215         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8216          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8217          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8218 ! Following matrices are needed only for 6-th order cumulants
8219         IF (wcorr6.gt.0.0d0) THEN
8220         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8221          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8222          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8223         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8224          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8225          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8226          ADtEAderx(1,1,1,1,1,1))
8227         lprn=.false.
8228         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8229          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8230          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8231          ADtEA1derx(1,1,1,1,1,1))
8232         ENDIF
8233 ! End 6-th order cumulants
8234 !d        lprn=.false.
8235 !d        if (lprn) then
8236 !d        write (2,*) 'In calc_eello6'
8237 !d        do iii=1,2
8238 !d          write (2,*) 'iii=',iii
8239 !d          do kkk=1,5
8240 !d            write (2,*) 'kkk=',kkk
8241 !d            do jjj=1,2
8242 !d              write (2,'(3(2f10.5),5x)')
8243 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8244 !d            enddo
8245 !d          enddo
8246 !d        enddo
8247 !d        endif
8248         call transpose2(EUgder(1,1,k),auxmat(1,1))
8249         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8250         call transpose2(EUg(1,1,k),auxmat(1,1))
8251         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8252         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8253         do iii=1,2
8254           do kkk=1,5
8255             do lll=1,3
8256               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8257                 EAEAderx(1,1,lll,kkk,iii,1))
8258             enddo
8259           enddo
8260         enddo
8261 ! A1T kernel(i+1) A2
8262         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8263          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8264          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8265 ! Following matrices are needed only for 6-th order cumulants
8266         IF (wcorr6.gt.0.0d0) THEN
8267         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8268          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8269          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8270         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8271          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8272          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8273          ADtEAderx(1,1,1,1,1,2))
8274         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8275          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8276          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8277          ADtEA1derx(1,1,1,1,1,2))
8278         ENDIF
8279 ! End 6-th order cumulants
8280         call transpose2(EUgder(1,1,l),auxmat(1,1))
8281         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8282         call transpose2(EUg(1,1,l),auxmat(1,1))
8283         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8284         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8285         do iii=1,2
8286           do kkk=1,5
8287             do lll=1,3
8288               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8289                 EAEAderx(1,1,lll,kkk,iii,2))
8290             enddo
8291           enddo
8292         enddo
8293 ! AEAb1 and AEAb2
8294 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8295 ! They are needed only when the fifth- or the sixth-order cumulants are
8296 ! indluded.
8297         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8298         call transpose2(AEA(1,1,1),auxmat(1,1))
8299         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8300         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8301         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8302         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8303         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8304         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8305         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8306         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8307         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8308         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8309         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8310         call transpose2(AEA(1,1,2),auxmat(1,1))
8311         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8312         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8313         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8314         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8315         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8316         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8317         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8318         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8319         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8320         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8321         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8322 ! Calculate the Cartesian derivatives of the vectors.
8323         do iii=1,2
8324           do kkk=1,5
8325             do lll=1,3
8326               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8327               call matvec2(auxmat(1,1),b1(1,iti),&
8328                 AEAb1derx(1,lll,kkk,iii,1,1))
8329               call matvec2(auxmat(1,1),Ub2(1,i),&
8330                 AEAb2derx(1,lll,kkk,iii,1,1))
8331               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8332                 AEAb1derx(1,lll,kkk,iii,2,1))
8333               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8334                 AEAb2derx(1,lll,kkk,iii,2,1))
8335               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8336               call matvec2(auxmat(1,1),b1(1,itj),&
8337                 AEAb1derx(1,lll,kkk,iii,1,2))
8338               call matvec2(auxmat(1,1),Ub2(1,j),&
8339                 AEAb2derx(1,lll,kkk,iii,1,2))
8340               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8341                 AEAb1derx(1,lll,kkk,iii,2,2))
8342               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8343                 AEAb2derx(1,lll,kkk,iii,2,2))
8344             enddo
8345           enddo
8346         enddo
8347         ENDIF
8348 ! End vectors
8349       else
8350 ! Antiparallel orientation of the two CA-CA-CA frames.
8351         if (i.gt.1) then
8352           iti=itortyp(itype(i,1))
8353         else
8354           iti=ntortyp+1
8355         endif
8356         itk1=itortyp(itype(k+1,1))
8357         itl=itortyp(itype(l,1))
8358         itj=itortyp(itype(j,1))
8359         if (j.lt.nres-1) then
8360           itj1=itortyp(itype(j+1,1))
8361         else
8362           itj1=ntortyp+1
8363         endif
8364 ! A2 kernel(j-1)T A1T
8365         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8366          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8367          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8368 ! Following matrices are needed only for 6-th order cumulants
8369         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8370            j.eq.i+4 .and. l.eq.i+3)) THEN
8371         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8372          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8373          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8374         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8375          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8376          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8377          ADtEAderx(1,1,1,1,1,1))
8378         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8379          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8380          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8381          ADtEA1derx(1,1,1,1,1,1))
8382         ENDIF
8383 ! End 6-th order cumulants
8384         call transpose2(EUgder(1,1,k),auxmat(1,1))
8385         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8386         call transpose2(EUg(1,1,k),auxmat(1,1))
8387         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8388         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8389         do iii=1,2
8390           do kkk=1,5
8391             do lll=1,3
8392               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8393                 EAEAderx(1,1,lll,kkk,iii,1))
8394             enddo
8395           enddo
8396         enddo
8397 ! A2T kernel(i+1)T A1
8398         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8399          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8400          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8401 ! Following matrices are needed only for 6-th order cumulants
8402         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8403            j.eq.i+4 .and. l.eq.i+3)) THEN
8404         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8405          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8406          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8407         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8408          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8409          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8410          ADtEAderx(1,1,1,1,1,2))
8411         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8412          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8413          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8414          ADtEA1derx(1,1,1,1,1,2))
8415         ENDIF
8416 ! End 6-th order cumulants
8417         call transpose2(EUgder(1,1,j),auxmat(1,1))
8418         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8419         call transpose2(EUg(1,1,j),auxmat(1,1))
8420         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8421         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8422         do iii=1,2
8423           do kkk=1,5
8424             do lll=1,3
8425               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8426                 EAEAderx(1,1,lll,kkk,iii,2))
8427             enddo
8428           enddo
8429         enddo
8430 ! AEAb1 and AEAb2
8431 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8432 ! They are needed only when the fifth- or the sixth-order cumulants are
8433 ! indluded.
8434         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8435           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8436         call transpose2(AEA(1,1,1),auxmat(1,1))
8437         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8438         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8439         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8440         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8441         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8442         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8443         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8444         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8445         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8446         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8447         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8448         call transpose2(AEA(1,1,2),auxmat(1,1))
8449         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8450         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8451         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8452         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8453         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8454         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8455         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8456         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8457         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8458         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8459         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8460 ! Calculate the Cartesian derivatives of the vectors.
8461         do iii=1,2
8462           do kkk=1,5
8463             do lll=1,3
8464               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8465               call matvec2(auxmat(1,1),b1(1,iti),&
8466                 AEAb1derx(1,lll,kkk,iii,1,1))
8467               call matvec2(auxmat(1,1),Ub2(1,i),&
8468                 AEAb2derx(1,lll,kkk,iii,1,1))
8469               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8470                 AEAb1derx(1,lll,kkk,iii,2,1))
8471               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8472                 AEAb2derx(1,lll,kkk,iii,2,1))
8473               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8474               call matvec2(auxmat(1,1),b1(1,itl),&
8475                 AEAb1derx(1,lll,kkk,iii,1,2))
8476               call matvec2(auxmat(1,1),Ub2(1,l),&
8477                 AEAb2derx(1,lll,kkk,iii,1,2))
8478               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8479                 AEAb1derx(1,lll,kkk,iii,2,2))
8480               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8481                 AEAb2derx(1,lll,kkk,iii,2,2))
8482             enddo
8483           enddo
8484         enddo
8485         ENDIF
8486 ! End vectors
8487       endif
8488       return
8489       end subroutine calc_eello
8490 !-----------------------------------------------------------------------------
8491       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8492       use comm_kut
8493       implicit none
8494       integer :: nderg
8495       logical :: transp
8496       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8497       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8498       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8499       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8500       integer :: iii,kkk,lll
8501       integer :: jjj,mmm
8502 !el      logical :: lprn
8503 !el      common /kutas/ lprn
8504       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8505       do iii=1,nderg
8506         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8507           AKAderg(1,1,iii))
8508       enddo
8509 !d      if (lprn) write (2,*) 'In kernel'
8510       do kkk=1,5
8511 !d        if (lprn) write (2,*) 'kkk=',kkk
8512         do lll=1,3
8513           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8514             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8515 !d          if (lprn) then
8516 !d            write (2,*) 'lll=',lll
8517 !d            write (2,*) 'iii=1'
8518 !d            do jjj=1,2
8519 !d              write (2,'(3(2f10.5),5x)')
8520 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8521 !d            enddo
8522 !d          endif
8523           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8524             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8525 !d          if (lprn) then
8526 !d            write (2,*) 'lll=',lll
8527 !d            write (2,*) 'iii=2'
8528 !d            do jjj=1,2
8529 !d              write (2,'(3(2f10.5),5x)')
8530 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8531 !d            enddo
8532 !d          endif
8533         enddo
8534       enddo
8535       return
8536       end subroutine kernel
8537 !-----------------------------------------------------------------------------
8538       real(kind=8) function eello4(i,j,k,l,jj,kk)
8539 !      implicit real*8 (a-h,o-z)
8540 !      include 'DIMENSIONS'
8541 !      include 'COMMON.IOUNITS'
8542 !      include 'COMMON.CHAIN'
8543 !      include 'COMMON.DERIV'
8544 !      include 'COMMON.INTERACT'
8545 !      include 'COMMON.CONTACTS'
8546 !      include 'COMMON.TORSION'
8547 !      include 'COMMON.VAR'
8548 !      include 'COMMON.GEO'
8549       real(kind=8),dimension(2,2) :: pizda
8550       real(kind=8),dimension(3) :: ggg1,ggg2
8551       real(kind=8) ::  eel4,glongij,glongkl
8552       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8553 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8554 !d        eello4=0.0d0
8555 !d        return
8556 !d      endif
8557 !d      print *,'eello4:',i,j,k,l,jj,kk
8558 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8559 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8560 !old      eij=facont_hb(jj,i)
8561 !old      ekl=facont_hb(kk,k)
8562 !old      ekont=eij*ekl
8563       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8564 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8565       gcorr_loc(k-1)=gcorr_loc(k-1) &
8566          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8567       if (l.eq.j+1) then
8568         gcorr_loc(l-1)=gcorr_loc(l-1) &
8569            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8570       else
8571         gcorr_loc(j-1)=gcorr_loc(j-1) &
8572            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8573       endif
8574       do iii=1,2
8575         do kkk=1,5
8576           do lll=1,3
8577             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8578                               -EAEAderx(2,2,lll,kkk,iii,1)
8579 !d            derx(lll,kkk,iii)=0.0d0
8580           enddo
8581         enddo
8582       enddo
8583 !d      gcorr_loc(l-1)=0.0d0
8584 !d      gcorr_loc(j-1)=0.0d0
8585 !d      gcorr_loc(k-1)=0.0d0
8586 !d      eel4=1.0d0
8587 !d      write (iout,*)'Contacts have occurred for peptide groups',
8588 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8589 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8590       if (j.lt.nres-1) then
8591         j1=j+1
8592         j2=j-1
8593       else
8594         j1=j-1
8595         j2=j-2
8596       endif
8597       if (l.lt.nres-1) then
8598         l1=l+1
8599         l2=l-1
8600       else
8601         l1=l-1
8602         l2=l-2
8603       endif
8604       do ll=1,3
8605 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8606 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8607         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8608         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8609 !grad        ghalf=0.5d0*ggg1(ll)
8610         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8611         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8612         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8613         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8614         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8615         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8616 !grad        ghalf=0.5d0*ggg2(ll)
8617         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8618         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8619         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8620         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8621         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8622         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8623       enddo
8624 !grad      do m=i+1,j-1
8625 !grad        do ll=1,3
8626 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8627 !grad        enddo
8628 !grad      enddo
8629 !grad      do m=k+1,l-1
8630 !grad        do ll=1,3
8631 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8632 !grad        enddo
8633 !grad      enddo
8634 !grad      do m=i+2,j2
8635 !grad        do ll=1,3
8636 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8637 !grad        enddo
8638 !grad      enddo
8639 !grad      do m=k+2,l2
8640 !grad        do ll=1,3
8641 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8642 !grad        enddo
8643 !grad      enddo
8644 !d      do iii=1,nres-3
8645 !d        write (2,*) iii,gcorr_loc(iii)
8646 !d      enddo
8647       eello4=ekont*eel4
8648 !d      write (2,*) 'ekont',ekont
8649 !d      write (iout,*) 'eello4',ekont*eel4
8650       return
8651       end function eello4
8652 !-----------------------------------------------------------------------------
8653       real(kind=8) function eello5(i,j,k,l,jj,kk)
8654 !      implicit real*8 (a-h,o-z)
8655 !      include 'DIMENSIONS'
8656 !      include 'COMMON.IOUNITS'
8657 !      include 'COMMON.CHAIN'
8658 !      include 'COMMON.DERIV'
8659 !      include 'COMMON.INTERACT'
8660 !      include 'COMMON.CONTACTS'
8661 !      include 'COMMON.TORSION'
8662 !      include 'COMMON.VAR'
8663 !      include 'COMMON.GEO'
8664       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8665       real(kind=8),dimension(2) :: vv
8666       real(kind=8),dimension(3) :: ggg1,ggg2
8667       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8668       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8669       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8670 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8671 !                                                                              C
8672 !                            Parallel chains                                   C
8673 !                                                                              C
8674 !          o             o                   o             o                   C
8675 !         /l\           / \             \   / \           / \   /              C
8676 !        /   \         /   \             \ /   \         /   \ /               C
8677 !       j| o |l1       | o |                o| o |         | o |o                C
8678 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8679 !      \i/   \         /   \ /             /   \         /   \                 C
8680 !       o    k1             o                                                  C
8681 !         (I)          (II)                (III)          (IV)                 C
8682 !                                                                              C
8683 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8684 !                                                                              C
8685 !                            Antiparallel chains                               C
8686 !                                                                              C
8687 !          o             o                   o             o                   C
8688 !         /j\           / \             \   / \           / \   /              C
8689 !        /   \         /   \             \ /   \         /   \ /               C
8690 !      j1| o |l        | o |                o| o |         | o |o                C
8691 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8692 !      \i/   \         /   \ /             /   \         /   \                 C
8693 !       o     k1            o                                                  C
8694 !         (I)          (II)                (III)          (IV)                 C
8695 !                                                                              C
8696 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8697 !                                                                              C
8698 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8699 !                                                                              C
8700 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8701 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8702 !d        eello5=0.0d0
8703 !d        return
8704 !d      endif
8705 !d      write (iout,*)
8706 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8707 !d     &   ' and',k,l
8708       itk=itortyp(itype(k,1))
8709       itl=itortyp(itype(l,1))
8710       itj=itortyp(itype(j,1))
8711       eello5_1=0.0d0
8712       eello5_2=0.0d0
8713       eello5_3=0.0d0
8714       eello5_4=0.0d0
8715 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8716 !d     &   eel5_3_num,eel5_4_num)
8717       do iii=1,2
8718         do kkk=1,5
8719           do lll=1,3
8720             derx(lll,kkk,iii)=0.0d0
8721           enddo
8722         enddo
8723       enddo
8724 !d      eij=facont_hb(jj,i)
8725 !d      ekl=facont_hb(kk,k)
8726 !d      ekont=eij*ekl
8727 !d      write (iout,*)'Contacts have occurred for peptide groups',
8728 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8729 !d      goto 1111
8730 ! Contribution from the graph I.
8731 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8732 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8733       call transpose2(EUg(1,1,k),auxmat(1,1))
8734       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8735       vv(1)=pizda(1,1)-pizda(2,2)
8736       vv(2)=pizda(1,2)+pizda(2,1)
8737       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8738        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8739 ! Explicit gradient in virtual-dihedral angles.
8740       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8741        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8742        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8743       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8744       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8745       vv(1)=pizda(1,1)-pizda(2,2)
8746       vv(2)=pizda(1,2)+pizda(2,1)
8747       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8748        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8749        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8750       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8751       vv(1)=pizda(1,1)-pizda(2,2)
8752       vv(2)=pizda(1,2)+pizda(2,1)
8753       if (l.eq.j+1) then
8754         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8755          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8756          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8757       else
8758         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8759          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8760          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8761       endif
8762 ! Cartesian gradient
8763       do iii=1,2
8764         do kkk=1,5
8765           do lll=1,3
8766             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8767               pizda(1,1))
8768             vv(1)=pizda(1,1)-pizda(2,2)
8769             vv(2)=pizda(1,2)+pizda(2,1)
8770             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8771              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8772              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8773           enddo
8774         enddo
8775       enddo
8776 !      goto 1112
8777 !1111  continue
8778 ! Contribution from graph II
8779       call transpose2(EE(1,1,itk),auxmat(1,1))
8780       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8781       vv(1)=pizda(1,1)+pizda(2,2)
8782       vv(2)=pizda(2,1)-pizda(1,2)
8783       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8784        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8785 ! Explicit gradient in virtual-dihedral angles.
8786       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8787        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8788       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8789       vv(1)=pizda(1,1)+pizda(2,2)
8790       vv(2)=pizda(2,1)-pizda(1,2)
8791       if (l.eq.j+1) then
8792         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8793          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8794          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8795       else
8796         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8797          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8798          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8799       endif
8800 ! Cartesian gradient
8801       do iii=1,2
8802         do kkk=1,5
8803           do lll=1,3
8804             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8805               pizda(1,1))
8806             vv(1)=pizda(1,1)+pizda(2,2)
8807             vv(2)=pizda(2,1)-pizda(1,2)
8808             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8809              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8810              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8811           enddo
8812         enddo
8813       enddo
8814 !d      goto 1112
8815 !d1111  continue
8816       if (l.eq.j+1) then
8817 !d        goto 1110
8818 ! Parallel orientation
8819 ! Contribution from graph III
8820         call transpose2(EUg(1,1,l),auxmat(1,1))
8821         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8822         vv(1)=pizda(1,1)-pizda(2,2)
8823         vv(2)=pizda(1,2)+pizda(2,1)
8824         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8825          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8826 ! Explicit gradient in virtual-dihedral angles.
8827         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8828          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8829          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8830         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8831         vv(1)=pizda(1,1)-pizda(2,2)
8832         vv(2)=pizda(1,2)+pizda(2,1)
8833         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8834          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8835          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8836         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8837         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8838         vv(1)=pizda(1,1)-pizda(2,2)
8839         vv(2)=pizda(1,2)+pizda(2,1)
8840         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8841          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8842          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8843 ! Cartesian gradient
8844         do iii=1,2
8845           do kkk=1,5
8846             do lll=1,3
8847               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8848                 pizda(1,1))
8849               vv(1)=pizda(1,1)-pizda(2,2)
8850               vv(2)=pizda(1,2)+pizda(2,1)
8851               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8852                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8853                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8854             enddo
8855           enddo
8856         enddo
8857 !d        goto 1112
8858 ! Contribution from graph IV
8859 !d1110    continue
8860         call transpose2(EE(1,1,itl),auxmat(1,1))
8861         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8862         vv(1)=pizda(1,1)+pizda(2,2)
8863         vv(2)=pizda(2,1)-pizda(1,2)
8864         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8865          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8866 ! Explicit gradient in virtual-dihedral angles.
8867         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8868          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8869         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8870         vv(1)=pizda(1,1)+pizda(2,2)
8871         vv(2)=pizda(2,1)-pizda(1,2)
8872         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8873          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8874          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8875 ! Cartesian gradient
8876         do iii=1,2
8877           do kkk=1,5
8878             do lll=1,3
8879               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8880                 pizda(1,1))
8881               vv(1)=pizda(1,1)+pizda(2,2)
8882               vv(2)=pizda(2,1)-pizda(1,2)
8883               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8884                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8885                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8886             enddo
8887           enddo
8888         enddo
8889       else
8890 ! Antiparallel orientation
8891 ! Contribution from graph III
8892 !        goto 1110
8893         call transpose2(EUg(1,1,j),auxmat(1,1))
8894         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8895         vv(1)=pizda(1,1)-pizda(2,2)
8896         vv(2)=pizda(1,2)+pizda(2,1)
8897         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8898          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8899 ! Explicit gradient in virtual-dihedral angles.
8900         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8901          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8902          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8903         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8904         vv(1)=pizda(1,1)-pizda(2,2)
8905         vv(2)=pizda(1,2)+pizda(2,1)
8906         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8907          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
8908          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8909         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8910         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8911         vv(1)=pizda(1,1)-pizda(2,2)
8912         vv(2)=pizda(1,2)+pizda(2,1)
8913         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8914          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
8915          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8916 ! Cartesian gradient
8917         do iii=1,2
8918           do kkk=1,5
8919             do lll=1,3
8920               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8921                 pizda(1,1))
8922               vv(1)=pizda(1,1)-pizda(2,2)
8923               vv(2)=pizda(1,2)+pizda(2,1)
8924               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8925                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
8926                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8927             enddo
8928           enddo
8929         enddo
8930 !d        goto 1112
8931 ! Contribution from graph IV
8932 1110    continue
8933         call transpose2(EE(1,1,itj),auxmat(1,1))
8934         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8935         vv(1)=pizda(1,1)+pizda(2,2)
8936         vv(2)=pizda(2,1)-pizda(1,2)
8937         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
8938          -0.5d0*scalar2(vv(1),Ctobr(1,j))
8939 ! Explicit gradient in virtual-dihedral angles.
8940         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8941          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8942         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8943         vv(1)=pizda(1,1)+pizda(2,2)
8944         vv(2)=pizda(2,1)-pizda(1,2)
8945         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8946          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
8947          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8948 ! Cartesian gradient
8949         do iii=1,2
8950           do kkk=1,5
8951             do lll=1,3
8952               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8953                 pizda(1,1))
8954               vv(1)=pizda(1,1)+pizda(2,2)
8955               vv(2)=pizda(2,1)-pizda(1,2)
8956               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8957                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
8958                -0.5d0*scalar2(vv(1),Ctobr(1,j))
8959             enddo
8960           enddo
8961         enddo
8962       endif
8963 1112  continue
8964       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8965 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8966 !d        write (2,*) 'ijkl',i,j,k,l
8967 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8968 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8969 !d      endif
8970 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8971 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8972 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8973 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8974       if (j.lt.nres-1) then
8975         j1=j+1
8976         j2=j-1
8977       else
8978         j1=j-1
8979         j2=j-2
8980       endif
8981       if (l.lt.nres-1) then
8982         l1=l+1
8983         l2=l-1
8984       else
8985         l1=l-1
8986         l2=l-2
8987       endif
8988 !d      eij=1.0d0
8989 !d      ekl=1.0d0
8990 !d      ekont=1.0d0
8991 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8992 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
8993 !        summed up outside the subrouine as for the other subroutines
8994 !        handling long-range interactions. The old code is commented out
8995 !        with "cgrad" to keep track of changes.
8996       do ll=1,3
8997 !grad        ggg1(ll)=eel5*g_contij(ll,1)
8998 !grad        ggg2(ll)=eel5*g_contij(ll,2)
8999         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9000         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9001 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9002 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9003 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9004 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9005 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9006 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9007 !     &   gradcorr5ij,
9008 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9009 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9010 !grad        ghalf=0.5d0*ggg1(ll)
9011 !d        ghalf=0.0d0
9012         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9013         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9014         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9015         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9016         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9017         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9018 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9019 !grad        ghalf=0.5d0*ggg2(ll)
9020         ghalf=0.0d0
9021         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9022         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9023         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9024         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9025         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9026         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9027       enddo
9028 !d      goto 1112
9029 !grad      do m=i+1,j-1
9030 !grad        do ll=1,3
9031 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9032 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9033 !grad        enddo
9034 !grad      enddo
9035 !grad      do m=k+1,l-1
9036 !grad        do ll=1,3
9037 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9038 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9039 !grad        enddo
9040 !grad      enddo
9041 !1112  continue
9042 !grad      do m=i+2,j2
9043 !grad        do ll=1,3
9044 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9045 !grad        enddo
9046 !grad      enddo
9047 !grad      do m=k+2,l2
9048 !grad        do ll=1,3
9049 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9050 !grad        enddo
9051 !grad      enddo
9052 !d      do iii=1,nres-3
9053 !d        write (2,*) iii,g_corr5_loc(iii)
9054 !d      enddo
9055       eello5=ekont*eel5
9056 !d      write (2,*) 'ekont',ekont
9057 !d      write (iout,*) 'eello5',ekont*eel5
9058       return
9059       end function eello5
9060 !-----------------------------------------------------------------------------
9061       real(kind=8) function eello6(i,j,k,l,jj,kk)
9062 !      implicit real*8 (a-h,o-z)
9063 !      include 'DIMENSIONS'
9064 !      include 'COMMON.IOUNITS'
9065 !      include 'COMMON.CHAIN'
9066 !      include 'COMMON.DERIV'
9067 !      include 'COMMON.INTERACT'
9068 !      include 'COMMON.CONTACTS'
9069 !      include 'COMMON.TORSION'
9070 !      include 'COMMON.VAR'
9071 !      include 'COMMON.GEO'
9072 !      include 'COMMON.FFIELD'
9073       real(kind=8),dimension(3) :: ggg1,ggg2
9074       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9075                    eello6_6,eel6
9076       real(kind=8) :: gradcorr6ij,gradcorr6kl
9077       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9078 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9079 !d        eello6=0.0d0
9080 !d        return
9081 !d      endif
9082 !d      write (iout,*)
9083 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9084 !d     &   ' and',k,l
9085       eello6_1=0.0d0
9086       eello6_2=0.0d0
9087       eello6_3=0.0d0
9088       eello6_4=0.0d0
9089       eello6_5=0.0d0
9090       eello6_6=0.0d0
9091 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9092 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9093       do iii=1,2
9094         do kkk=1,5
9095           do lll=1,3
9096             derx(lll,kkk,iii)=0.0d0
9097           enddo
9098         enddo
9099       enddo
9100 !d      eij=facont_hb(jj,i)
9101 !d      ekl=facont_hb(kk,k)
9102 !d      ekont=eij*ekl
9103 !d      eij=1.0d0
9104 !d      ekl=1.0d0
9105 !d      ekont=1.0d0
9106       if (l.eq.j+1) then
9107         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9108         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9109         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9110         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9111         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9112         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9113       else
9114         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9115         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9116         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9117         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9118         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9119           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9120         else
9121           eello6_5=0.0d0
9122         endif
9123         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9124       endif
9125 ! If turn contributions are considered, they will be handled separately.
9126       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9127 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9128 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9129 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9130 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9131 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9132 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9133 !d      goto 1112
9134       if (j.lt.nres-1) then
9135         j1=j+1
9136         j2=j-1
9137       else
9138         j1=j-1
9139         j2=j-2
9140       endif
9141       if (l.lt.nres-1) then
9142         l1=l+1
9143         l2=l-1
9144       else
9145         l1=l-1
9146         l2=l-2
9147       endif
9148       do ll=1,3
9149 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9150 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9151 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9152 !grad        ghalf=0.5d0*ggg1(ll)
9153 !d        ghalf=0.0d0
9154         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9155         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9156         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9157         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9158         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9159         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9160         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9161         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9162 !grad        ghalf=0.5d0*ggg2(ll)
9163 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9164 !d        ghalf=0.0d0
9165         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9166         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9167         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9168         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9169         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9170         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9171       enddo
9172 !d      goto 1112
9173 !grad      do m=i+1,j-1
9174 !grad        do ll=1,3
9175 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9176 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9177 !grad        enddo
9178 !grad      enddo
9179 !grad      do m=k+1,l-1
9180 !grad        do ll=1,3
9181 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9182 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9183 !grad        enddo
9184 !grad      enddo
9185 !grad1112  continue
9186 !grad      do m=i+2,j2
9187 !grad        do ll=1,3
9188 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9189 !grad        enddo
9190 !grad      enddo
9191 !grad      do m=k+2,l2
9192 !grad        do ll=1,3
9193 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9194 !grad        enddo
9195 !grad      enddo
9196 !d      do iii=1,nres-3
9197 !d        write (2,*) iii,g_corr6_loc(iii)
9198 !d      enddo
9199       eello6=ekont*eel6
9200 !d      write (2,*) 'ekont',ekont
9201 !d      write (iout,*) 'eello6',ekont*eel6
9202       return
9203       end function eello6
9204 !-----------------------------------------------------------------------------
9205       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9206       use comm_kut
9207 !      implicit real*8 (a-h,o-z)
9208 !      include 'DIMENSIONS'
9209 !      include 'COMMON.IOUNITS'
9210 !      include 'COMMON.CHAIN'
9211 !      include 'COMMON.DERIV'
9212 !      include 'COMMON.INTERACT'
9213 !      include 'COMMON.CONTACTS'
9214 !      include 'COMMON.TORSION'
9215 !      include 'COMMON.VAR'
9216 !      include 'COMMON.GEO'
9217       real(kind=8),dimension(2) :: vv,vv1
9218       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9219       logical :: swap
9220 !el      logical :: lprn
9221 !el      common /kutas/ lprn
9222       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9223       real(kind=8) :: s1,s2,s3,s4,s5
9224 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9225 !                                                                              C
9226 !      Parallel       Antiparallel                                             C
9227 !                                                                              C
9228 !          o             o                                                     C
9229 !         /l\           /j\                                                    C
9230 !        /   \         /   \                                                   C
9231 !       /| o |         | o |\                                                  C
9232 !     \ j|/k\|  /   \  |/k\|l /                                                C
9233 !      \ /   \ /     \ /   \ /                                                 C
9234 !       o     o       o     o                                                  C
9235 !       i             i                                                        C
9236 !                                                                              C
9237 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9238       itk=itortyp(itype(k,1))
9239       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9240       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9241       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9242       call transpose2(EUgC(1,1,k),auxmat(1,1))
9243       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9244       vv1(1)=pizda1(1,1)-pizda1(2,2)
9245       vv1(2)=pizda1(1,2)+pizda1(2,1)
9246       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9247       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9248       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9249       s5=scalar2(vv(1),Dtobr2(1,i))
9250 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9251       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9252       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9253        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9254        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9255        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9256        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9257        +scalar2(vv(1),Dtobr2der(1,i)))
9258       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9259       vv1(1)=pizda1(1,1)-pizda1(2,2)
9260       vv1(2)=pizda1(1,2)+pizda1(2,1)
9261       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9262       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9263       if (l.eq.j+1) then
9264         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9265        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9266        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9267        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9268        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9269       else
9270         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9271        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9272        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9273        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9274        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9275       endif
9276       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9277       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9278       vv1(1)=pizda1(1,1)-pizda1(2,2)
9279       vv1(2)=pizda1(1,2)+pizda1(2,1)
9280       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9281        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9282        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9283        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9284       do iii=1,2
9285         if (swap) then
9286           ind=3-iii
9287         else
9288           ind=iii
9289         endif
9290         do kkk=1,5
9291           do lll=1,3
9292             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9293             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9294             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9295             call transpose2(EUgC(1,1,k),auxmat(1,1))
9296             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9297               pizda1(1,1))
9298             vv1(1)=pizda1(1,1)-pizda1(2,2)
9299             vv1(2)=pizda1(1,2)+pizda1(2,1)
9300             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9301             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9302              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9303             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9304              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9305             s5=scalar2(vv(1),Dtobr2(1,i))
9306             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9307           enddo
9308         enddo
9309       enddo
9310       return
9311       end function eello6_graph1
9312 !-----------------------------------------------------------------------------
9313       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9314       use comm_kut
9315 !      implicit real*8 (a-h,o-z)
9316 !      include 'DIMENSIONS'
9317 !      include 'COMMON.IOUNITS'
9318 !      include 'COMMON.CHAIN'
9319 !      include 'COMMON.DERIV'
9320 !      include 'COMMON.INTERACT'
9321 !      include 'COMMON.CONTACTS'
9322 !      include 'COMMON.TORSION'
9323 !      include 'COMMON.VAR'
9324 !      include 'COMMON.GEO'
9325       logical :: swap
9326       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9327       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9328 !el      logical :: lprn
9329 !el      common /kutas/ lprn
9330       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9331       real(kind=8) :: s2,s3,s4
9332 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9333 !                                                                              C
9334 !      Parallel       Antiparallel                                             C
9335 !                                                                              C
9336 !          o             o                                                     C
9337 !     \   /l\           /j\   /                                                C
9338 !      \ /   \         /   \ /                                                 C
9339 !       o| o |         | o |o                                                  C
9340 !     \ j|/k\|      \  |/k\|l                                                  C
9341 !      \ /   \       \ /   \                                                   C
9342 !       o             o                                                        C
9343 !       i             i                                                        C
9344 !                                                                              C
9345 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9346 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9347 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9348 !           but not in a cluster cumulant
9349 #ifdef MOMENT
9350       s1=dip(1,jj,i)*dip(1,kk,k)
9351 #endif
9352       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9353       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9354       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9355       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9356       call transpose2(EUg(1,1,k),auxmat(1,1))
9357       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9358       vv(1)=pizda(1,1)-pizda(2,2)
9359       vv(2)=pizda(1,2)+pizda(2,1)
9360       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9361 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9362 #ifdef MOMENT
9363       eello6_graph2=-(s1+s2+s3+s4)
9364 #else
9365       eello6_graph2=-(s2+s3+s4)
9366 #endif
9367 !      eello6_graph2=-s3
9368 ! Derivatives in gamma(i-1)
9369       if (i.gt.1) then
9370 #ifdef MOMENT
9371         s1=dipderg(1,jj,i)*dip(1,kk,k)
9372 #endif
9373         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9374         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9375         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9376         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9377 #ifdef MOMENT
9378         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9379 #else
9380         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9381 #endif
9382 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9383       endif
9384 ! Derivatives in gamma(k-1)
9385 #ifdef MOMENT
9386       s1=dip(1,jj,i)*dipderg(1,kk,k)
9387 #endif
9388       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9389       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9390       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9391       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9392       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9393       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9394       vv(1)=pizda(1,1)-pizda(2,2)
9395       vv(2)=pizda(1,2)+pizda(2,1)
9396       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9397 #ifdef MOMENT
9398       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9399 #else
9400       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9401 #endif
9402 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9403 ! Derivatives in gamma(j-1) or gamma(l-1)
9404       if (j.gt.1) then
9405 #ifdef MOMENT
9406         s1=dipderg(3,jj,i)*dip(1,kk,k)
9407 #endif
9408         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9409         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9410         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9411         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9412         vv(1)=pizda(1,1)-pizda(2,2)
9413         vv(2)=pizda(1,2)+pizda(2,1)
9414         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9415 #ifdef MOMENT
9416         if (swap) then
9417           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9418         else
9419           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9420         endif
9421 #endif
9422         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9423 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9424       endif
9425 ! Derivatives in gamma(l-1) or gamma(j-1)
9426       if (l.gt.1) then
9427 #ifdef MOMENT
9428         s1=dip(1,jj,i)*dipderg(3,kk,k)
9429 #endif
9430         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9431         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9432         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9433         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9434         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9435         vv(1)=pizda(1,1)-pizda(2,2)
9436         vv(2)=pizda(1,2)+pizda(2,1)
9437         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9438 #ifdef MOMENT
9439         if (swap) then
9440           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9441         else
9442           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9443         endif
9444 #endif
9445         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9446 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9447       endif
9448 ! Cartesian derivatives.
9449       if (lprn) then
9450         write (2,*) 'In eello6_graph2'
9451         do iii=1,2
9452           write (2,*) 'iii=',iii
9453           do kkk=1,5
9454             write (2,*) 'kkk=',kkk
9455             do jjj=1,2
9456               write (2,'(3(2f10.5),5x)') &
9457               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9458             enddo
9459           enddo
9460         enddo
9461       endif
9462       do iii=1,2
9463         do kkk=1,5
9464           do lll=1,3
9465 #ifdef MOMENT
9466             if (iii.eq.1) then
9467               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9468             else
9469               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9470             endif
9471 #endif
9472             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9473               auxvec(1))
9474             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9475             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9476               auxvec(1))
9477             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9478             call transpose2(EUg(1,1,k),auxmat(1,1))
9479             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9480               pizda(1,1))
9481             vv(1)=pizda(1,1)-pizda(2,2)
9482             vv(2)=pizda(1,2)+pizda(2,1)
9483             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9484 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9485 #ifdef MOMENT
9486             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9487 #else
9488             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9489 #endif
9490             if (swap) then
9491               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9492             else
9493               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9494             endif
9495           enddo
9496         enddo
9497       enddo
9498       return
9499       end function eello6_graph2
9500 !-----------------------------------------------------------------------------
9501       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9502 !      implicit real*8 (a-h,o-z)
9503 !      include 'DIMENSIONS'
9504 !      include 'COMMON.IOUNITS'
9505 !      include 'COMMON.CHAIN'
9506 !      include 'COMMON.DERIV'
9507 !      include 'COMMON.INTERACT'
9508 !      include 'COMMON.CONTACTS'
9509 !      include 'COMMON.TORSION'
9510 !      include 'COMMON.VAR'
9511 !      include 'COMMON.GEO'
9512       real(kind=8),dimension(2) :: vv,auxvec
9513       real(kind=8),dimension(2,2) :: pizda,auxmat
9514       logical :: swap
9515       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9516       real(kind=8) :: s1,s2,s3,s4
9517 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9518 !                                                                              C
9519 !      Parallel       Antiparallel                                             C
9520 !                                                                              C
9521 !          o             o                                                     C
9522 !         /l\   /   \   /j\                                                    C
9523 !        /   \ /     \ /   \                                                   C
9524 !       /| o |o       o| o |\                                                  C
9525 !       j|/k\|  /      |/k\|l /                                                C
9526 !        /   \ /       /   \ /                                                 C
9527 !       /     o       /     o                                                  C
9528 !       i             i                                                        C
9529 !                                                                              C
9530 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9531 !
9532 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9533 !           energy moment and not to the cluster cumulant.
9534       iti=itortyp(itype(i,1))
9535       if (j.lt.nres-1) then
9536         itj1=itortyp(itype(j+1,1))
9537       else
9538         itj1=ntortyp+1
9539       endif
9540       itk=itortyp(itype(k,1))
9541       itk1=itortyp(itype(k+1,1))
9542       if (l.lt.nres-1) then
9543         itl1=itortyp(itype(l+1,1))
9544       else
9545         itl1=ntortyp+1
9546       endif
9547 #ifdef MOMENT
9548       s1=dip(4,jj,i)*dip(4,kk,k)
9549 #endif
9550       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9551       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9552       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9553       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9554       call transpose2(EE(1,1,itk),auxmat(1,1))
9555       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9556       vv(1)=pizda(1,1)+pizda(2,2)
9557       vv(2)=pizda(2,1)-pizda(1,2)
9558       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9559 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9560 !d     & "sum",-(s2+s3+s4)
9561 #ifdef MOMENT
9562       eello6_graph3=-(s1+s2+s3+s4)
9563 #else
9564       eello6_graph3=-(s2+s3+s4)
9565 #endif
9566 !      eello6_graph3=-s4
9567 ! Derivatives in gamma(k-1)
9568       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9569       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9570       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9571       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9572 ! Derivatives in gamma(l-1)
9573       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9574       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9575       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9576       vv(1)=pizda(1,1)+pizda(2,2)
9577       vv(2)=pizda(2,1)-pizda(1,2)
9578       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9579       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9580 ! Cartesian derivatives.
9581       do iii=1,2
9582         do kkk=1,5
9583           do lll=1,3
9584 #ifdef MOMENT
9585             if (iii.eq.1) then
9586               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9587             else
9588               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9589             endif
9590 #endif
9591             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9592               auxvec(1))
9593             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9594             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9595               auxvec(1))
9596             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9597             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9598               pizda(1,1))
9599             vv(1)=pizda(1,1)+pizda(2,2)
9600             vv(2)=pizda(2,1)-pizda(1,2)
9601             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9602 #ifdef MOMENT
9603             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9604 #else
9605             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9606 #endif
9607             if (swap) then
9608               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9609             else
9610               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9611             endif
9612 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9613           enddo
9614         enddo
9615       enddo
9616       return
9617       end function eello6_graph3
9618 !-----------------------------------------------------------------------------
9619       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9620 !      implicit real*8 (a-h,o-z)
9621 !      include 'DIMENSIONS'
9622 !      include 'COMMON.IOUNITS'
9623 !      include 'COMMON.CHAIN'
9624 !      include 'COMMON.DERIV'
9625 !      include 'COMMON.INTERACT'
9626 !      include 'COMMON.CONTACTS'
9627 !      include 'COMMON.TORSION'
9628 !      include 'COMMON.VAR'
9629 !      include 'COMMON.GEO'
9630 !      include 'COMMON.FFIELD'
9631       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9632       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9633       logical :: swap
9634       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9635               iii,kkk,lll
9636       real(kind=8) :: s1,s2,s3,s4
9637 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9638 !                                                                              C
9639 !      Parallel       Antiparallel                                             C
9640 !                                                                              C
9641 !          o             o                                                     C
9642 !         /l\   /   \   /j\                                                    C
9643 !        /   \ /     \ /   \                                                   C
9644 !       /| o |o       o| o |\                                                  C
9645 !     \ j|/k\|      \  |/k\|l                                                  C
9646 !      \ /   \       \ /   \                                                   C
9647 !       o     \       o     \                                                  C
9648 !       i             i                                                        C
9649 !                                                                              C
9650 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9651 !
9652 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9653 !           energy moment and not to the cluster cumulant.
9654 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9655       iti=itortyp(itype(i,1))
9656       itj=itortyp(itype(j,1))
9657       if (j.lt.nres-1) then
9658         itj1=itortyp(itype(j+1,1))
9659       else
9660         itj1=ntortyp+1
9661       endif
9662       itk=itortyp(itype(k,1))
9663       if (k.lt.nres-1) then
9664         itk1=itortyp(itype(k+1,1))
9665       else
9666         itk1=ntortyp+1
9667       endif
9668       itl=itortyp(itype(l,1))
9669       if (l.lt.nres-1) then
9670         itl1=itortyp(itype(l+1,1))
9671       else
9672         itl1=ntortyp+1
9673       endif
9674 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9675 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9676 !d     & ' itl',itl,' itl1',itl1
9677 #ifdef MOMENT
9678       if (imat.eq.1) then
9679         s1=dip(3,jj,i)*dip(3,kk,k)
9680       else
9681         s1=dip(2,jj,j)*dip(2,kk,l)
9682       endif
9683 #endif
9684       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9685       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9686       if (j.eq.l+1) then
9687         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9688         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9689       else
9690         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9691         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9692       endif
9693       call transpose2(EUg(1,1,k),auxmat(1,1))
9694       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9695       vv(1)=pizda(1,1)-pizda(2,2)
9696       vv(2)=pizda(2,1)+pizda(1,2)
9697       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9698 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9699 #ifdef MOMENT
9700       eello6_graph4=-(s1+s2+s3+s4)
9701 #else
9702       eello6_graph4=-(s2+s3+s4)
9703 #endif
9704 ! Derivatives in gamma(i-1)
9705       if (i.gt.1) then
9706 #ifdef MOMENT
9707         if (imat.eq.1) then
9708           s1=dipderg(2,jj,i)*dip(3,kk,k)
9709         else
9710           s1=dipderg(4,jj,j)*dip(2,kk,l)
9711         endif
9712 #endif
9713         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9714         if (j.eq.l+1) then
9715           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9716           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9717         else
9718           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9719           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9720         endif
9721         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9722         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9723 !d          write (2,*) 'turn6 derivatives'
9724 #ifdef MOMENT
9725           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9726 #else
9727           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9728 #endif
9729         else
9730 #ifdef MOMENT
9731           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9732 #else
9733           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9734 #endif
9735         endif
9736       endif
9737 ! Derivatives in gamma(k-1)
9738 #ifdef MOMENT
9739       if (imat.eq.1) then
9740         s1=dip(3,jj,i)*dipderg(2,kk,k)
9741       else
9742         s1=dip(2,jj,j)*dipderg(4,kk,l)
9743       endif
9744 #endif
9745       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9746       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9747       if (j.eq.l+1) then
9748         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9749         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9750       else
9751         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9752         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9753       endif
9754       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9755       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9756       vv(1)=pizda(1,1)-pizda(2,2)
9757       vv(2)=pizda(2,1)+pizda(1,2)
9758       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9759       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9760 #ifdef MOMENT
9761         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9762 #else
9763         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9764 #endif
9765       else
9766 #ifdef MOMENT
9767         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9768 #else
9769         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9770 #endif
9771       endif
9772 ! Derivatives in gamma(j-1) or gamma(l-1)
9773       if (l.eq.j+1 .and. l.gt.1) then
9774         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9775         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9776         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9777         vv(1)=pizda(1,1)-pizda(2,2)
9778         vv(2)=pizda(2,1)+pizda(1,2)
9779         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9780         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9781       else if (j.gt.1) then
9782         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9783         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9784         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9785         vv(1)=pizda(1,1)-pizda(2,2)
9786         vv(2)=pizda(2,1)+pizda(1,2)
9787         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9788         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9789           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9790         else
9791           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9792         endif
9793       endif
9794 ! Cartesian derivatives.
9795       do iii=1,2
9796         do kkk=1,5
9797           do lll=1,3
9798 #ifdef MOMENT
9799             if (iii.eq.1) then
9800               if (imat.eq.1) then
9801                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9802               else
9803                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9804               endif
9805             else
9806               if (imat.eq.1) then
9807                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9808               else
9809                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9810               endif
9811             endif
9812 #endif
9813             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9814               auxvec(1))
9815             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9816             if (j.eq.l+1) then
9817               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9818                 b1(1,itj1),auxvec(1))
9819               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9820             else
9821               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9822                 b1(1,itl1),auxvec(1))
9823               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9824             endif
9825             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9826               pizda(1,1))
9827             vv(1)=pizda(1,1)-pizda(2,2)
9828             vv(2)=pizda(2,1)+pizda(1,2)
9829             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9830             if (swap) then
9831               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9832 #ifdef MOMENT
9833                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9834                    -(s1+s2+s4)
9835 #else
9836                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9837                    -(s2+s4)
9838 #endif
9839                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9840               else
9841 #ifdef MOMENT
9842                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9843 #else
9844                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9845 #endif
9846                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9847               endif
9848             else
9849 #ifdef MOMENT
9850               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9851 #else
9852               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9853 #endif
9854               if (l.eq.j+1) then
9855                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9856               else
9857                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9858               endif
9859             endif
9860           enddo
9861         enddo
9862       enddo
9863       return
9864       end function eello6_graph4
9865 !-----------------------------------------------------------------------------
9866       real(kind=8) function eello_turn6(i,jj,kk)
9867 !      implicit real*8 (a-h,o-z)
9868 !      include 'DIMENSIONS'
9869 !      include 'COMMON.IOUNITS'
9870 !      include 'COMMON.CHAIN'
9871 !      include 'COMMON.DERIV'
9872 !      include 'COMMON.INTERACT'
9873 !      include 'COMMON.CONTACTS'
9874 !      include 'COMMON.TORSION'
9875 !      include 'COMMON.VAR'
9876 !      include 'COMMON.GEO'
9877       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9878       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9879       real(kind=8),dimension(3) :: ggg1,ggg2
9880       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9881       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9882 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9883 !           the respective energy moment and not to the cluster cumulant.
9884 !el local variables
9885       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9886       integer :: j1,j2,l1,l2,ll
9887       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9888       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9889       s1=0.0d0
9890       s8=0.0d0
9891       s13=0.0d0
9892 !
9893       eello_turn6=0.0d0
9894       j=i+4
9895       k=i+1
9896       l=i+3
9897       iti=itortyp(itype(i,1))
9898       itk=itortyp(itype(k,1))
9899       itk1=itortyp(itype(k+1,1))
9900       itl=itortyp(itype(l,1))
9901       itj=itortyp(itype(j,1))
9902 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9903 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
9904 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9905 !d        eello6=0.0d0
9906 !d        return
9907 !d      endif
9908 !d      write (iout,*)
9909 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9910 !d     &   ' and',k,l
9911 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
9912       do iii=1,2
9913         do kkk=1,5
9914           do lll=1,3
9915             derx_turn(lll,kkk,iii)=0.0d0
9916           enddo
9917         enddo
9918       enddo
9919 !d      eij=1.0d0
9920 !d      ekl=1.0d0
9921 !d      ekont=1.0d0
9922       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9923 !d      eello6_5=0.0d0
9924 !d      write (2,*) 'eello6_5',eello6_5
9925 #ifdef MOMENT
9926       call transpose2(AEA(1,1,1),auxmat(1,1))
9927       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9928       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9929       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9930 #endif
9931       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9932       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9933       s2 = scalar2(b1(1,itk),vtemp1(1))
9934 #ifdef MOMENT
9935       call transpose2(AEA(1,1,2),atemp(1,1))
9936       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9937       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9938       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9939 #endif
9940       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9941       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9942       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9943 #ifdef MOMENT
9944       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9945       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9946       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9947       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9948       ss13 = scalar2(b1(1,itk),vtemp4(1))
9949       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9950 #endif
9951 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9952 !      s1=0.0d0
9953 !      s2=0.0d0
9954 !      s8=0.0d0
9955 !      s12=0.0d0
9956 !      s13=0.0d0
9957       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9958 ! Derivatives in gamma(i+2)
9959       s1d =0.0d0
9960       s8d =0.0d0
9961 #ifdef MOMENT
9962       call transpose2(AEA(1,1,1),auxmatd(1,1))
9963       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9964       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9965       call transpose2(AEAderg(1,1,2),atempd(1,1))
9966       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9967       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9968 #endif
9969       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9970       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9971       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9972 !      s1d=0.0d0
9973 !      s2d=0.0d0
9974 !      s8d=0.0d0
9975 !      s12d=0.0d0
9976 !      s13d=0.0d0
9977       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9978 ! Derivatives in gamma(i+3)
9979 #ifdef MOMENT
9980       call transpose2(AEA(1,1,1),auxmatd(1,1))
9981       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9982       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9983       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9984 #endif
9985       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9986       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9987       s2d = scalar2(b1(1,itk),vtemp1d(1))
9988 #ifdef MOMENT
9989       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9990       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9991 #endif
9992       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9993 #ifdef MOMENT
9994       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9995       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9996       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9997 #endif
9998 !      s1d=0.0d0
9999 !      s2d=0.0d0
10000 !      s8d=0.0d0
10001 !      s12d=0.0d0
10002 !      s13d=0.0d0
10003 #ifdef MOMENT
10004       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10005                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10006 #else
10007       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10008                     -0.5d0*ekont*(s2d+s12d)
10009 #endif
10010 ! Derivatives in gamma(i+4)
10011       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10012       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10013       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10014 #ifdef MOMENT
10015       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10016       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10017       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10018 #endif
10019 !      s1d=0.0d0
10020 !      s2d=0.0d0
10021 !      s8d=0.0d0
10022 !      s12d=0.0d0
10023 !      s13d=0.0d0
10024 #ifdef MOMENT
10025       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10026 #else
10027       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10028 #endif
10029 ! Derivatives in gamma(i+5)
10030 #ifdef MOMENT
10031       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10032       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10033       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10034 #endif
10035       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10036       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10037       s2d = scalar2(b1(1,itk),vtemp1d(1))
10038 #ifdef MOMENT
10039       call transpose2(AEA(1,1,2),atempd(1,1))
10040       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10041       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10042 #endif
10043       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10044       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10045 #ifdef MOMENT
10046       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10047       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10048       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10049 #endif
10050 !      s1d=0.0d0
10051 !      s2d=0.0d0
10052 !      s8d=0.0d0
10053 !      s12d=0.0d0
10054 !      s13d=0.0d0
10055 #ifdef MOMENT
10056       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10057                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10058 #else
10059       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10060                     -0.5d0*ekont*(s2d+s12d)
10061 #endif
10062 ! Cartesian derivatives
10063       do iii=1,2
10064         do kkk=1,5
10065           do lll=1,3
10066 #ifdef MOMENT
10067             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10068             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10069             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10070 #endif
10071             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10072             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10073                 vtemp1d(1))
10074             s2d = scalar2(b1(1,itk),vtemp1d(1))
10075 #ifdef MOMENT
10076             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10077             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10078             s8d = -(atempd(1,1)+atempd(2,2))* &
10079                  scalar2(cc(1,1,itl),vtemp2(1))
10080 #endif
10081             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10082                  auxmatd(1,1))
10083             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10084             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10085 !      s1d=0.0d0
10086 !      s2d=0.0d0
10087 !      s8d=0.0d0
10088 !      s12d=0.0d0
10089 !      s13d=0.0d0
10090 #ifdef MOMENT
10091             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10092               - 0.5d0*(s1d+s2d)
10093 #else
10094             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10095               - 0.5d0*s2d
10096 #endif
10097 #ifdef MOMENT
10098             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10099               - 0.5d0*(s8d+s12d)
10100 #else
10101             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10102               - 0.5d0*s12d
10103 #endif
10104           enddo
10105         enddo
10106       enddo
10107 #ifdef MOMENT
10108       do kkk=1,5
10109         do lll=1,3
10110           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10111             achuj_tempd(1,1))
10112           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10113           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10114           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10115           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10116           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10117             vtemp4d(1))
10118           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10119           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10120           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10121         enddo
10122       enddo
10123 #endif
10124 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10125 !d     &  16*eel_turn6_num
10126 !d      goto 1112
10127       if (j.lt.nres-1) then
10128         j1=j+1
10129         j2=j-1
10130       else
10131         j1=j-1
10132         j2=j-2
10133       endif
10134       if (l.lt.nres-1) then
10135         l1=l+1
10136         l2=l-1
10137       else
10138         l1=l-1
10139         l2=l-2
10140       endif
10141       do ll=1,3
10142 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10143 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10144 !grad        ghalf=0.5d0*ggg1(ll)
10145 !d        ghalf=0.0d0
10146         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10147         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10148         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10149           +ekont*derx_turn(ll,2,1)
10150         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10151         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10152           +ekont*derx_turn(ll,4,1)
10153         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10154         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10155         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10156 !grad        ghalf=0.5d0*ggg2(ll)
10157 !d        ghalf=0.0d0
10158         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10159           +ekont*derx_turn(ll,2,2)
10160         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10161         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10162           +ekont*derx_turn(ll,4,2)
10163         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10164         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10165         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10166       enddo
10167 !d      goto 1112
10168 !grad      do m=i+1,j-1
10169 !grad        do ll=1,3
10170 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10171 !grad        enddo
10172 !grad      enddo
10173 !grad      do m=k+1,l-1
10174 !grad        do ll=1,3
10175 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10176 !grad        enddo
10177 !grad      enddo
10178 !grad1112  continue
10179 !grad      do m=i+2,j2
10180 !grad        do ll=1,3
10181 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10182 !grad        enddo
10183 !grad      enddo
10184 !grad      do m=k+2,l2
10185 !grad        do ll=1,3
10186 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10187 !grad        enddo
10188 !grad      enddo
10189 !d      do iii=1,nres-3
10190 !d        write (2,*) iii,g_corr6_loc(iii)
10191 !d      enddo
10192       eello_turn6=ekont*eel_turn6
10193 !d      write (2,*) 'ekont',ekont
10194 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10195       return
10196       end function eello_turn6
10197 !-----------------------------------------------------------------------------
10198       subroutine MATVEC2(A1,V1,V2)
10199 !DIR$ INLINEALWAYS MATVEC2
10200 #ifndef OSF
10201 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10202 #endif
10203 !      implicit real*8 (a-h,o-z)
10204 !      include 'DIMENSIONS'
10205       real(kind=8),dimension(2) :: V1,V2
10206       real(kind=8),dimension(2,2) :: A1
10207       real(kind=8) :: vaux1,vaux2
10208 !      DO 1 I=1,2
10209 !        VI=0.0
10210 !        DO 3 K=1,2
10211 !    3     VI=VI+A1(I,K)*V1(K)
10212 !        Vaux(I)=VI
10213 !    1 CONTINUE
10214
10215       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10216       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10217
10218       v2(1)=vaux1
10219       v2(2)=vaux2
10220       end subroutine MATVEC2
10221 !-----------------------------------------------------------------------------
10222       subroutine MATMAT2(A1,A2,A3)
10223 #ifndef OSF
10224 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10225 #endif
10226 !      implicit real*8 (a-h,o-z)
10227 !      include 'DIMENSIONS'
10228       real(kind=8),dimension(2,2) :: A1,A2,A3
10229       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10230 !      DIMENSION AI3(2,2)
10231 !        DO  J=1,2
10232 !          A3IJ=0.0
10233 !          DO K=1,2
10234 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10235 !          enddo
10236 !          A3(I,J)=A3IJ
10237 !       enddo
10238 !      enddo
10239
10240       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10241       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10242       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10243       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10244
10245       A3(1,1)=AI3_11
10246       A3(2,1)=AI3_21
10247       A3(1,2)=AI3_12
10248       A3(2,2)=AI3_22
10249       end subroutine MATMAT2
10250 !-----------------------------------------------------------------------------
10251       real(kind=8) function scalar2(u,v)
10252 !DIR$ INLINEALWAYS scalar2
10253       implicit none
10254       real(kind=8),dimension(2) :: u,v
10255       real(kind=8) :: sc
10256       integer :: i
10257       scalar2=u(1)*v(1)+u(2)*v(2)
10258       return
10259       end function scalar2
10260 !-----------------------------------------------------------------------------
10261       subroutine transpose2(a,at)
10262 !DIR$ INLINEALWAYS transpose2
10263 #ifndef OSF
10264 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10265 #endif
10266       implicit none
10267       real(kind=8),dimension(2,2) :: a,at
10268       at(1,1)=a(1,1)
10269       at(1,2)=a(2,1)
10270       at(2,1)=a(1,2)
10271       at(2,2)=a(2,2)
10272       return
10273       end subroutine transpose2
10274 !-----------------------------------------------------------------------------
10275       subroutine transpose(n,a,at)
10276       implicit none
10277       integer :: n,i,j
10278       real(kind=8),dimension(n,n) :: a,at
10279       do i=1,n
10280         do j=1,n
10281           at(j,i)=a(i,j)
10282         enddo
10283       enddo
10284       return
10285       end subroutine transpose
10286 !-----------------------------------------------------------------------------
10287       subroutine prodmat3(a1,a2,kk,transp,prod)
10288 !DIR$ INLINEALWAYS prodmat3
10289 #ifndef OSF
10290 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10291 #endif
10292       implicit none
10293       integer :: i,j
10294       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10295       logical :: transp
10296 !rc      double precision auxmat(2,2),prod_(2,2)
10297
10298       if (transp) then
10299 !rc        call transpose2(kk(1,1),auxmat(1,1))
10300 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10301 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10302
10303            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10304        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10305            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10306        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10307            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10308        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10309            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10310        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10311
10312       else
10313 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10314 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10315
10316            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10317         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10318            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10319         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10320            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10321         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10322            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10323         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10324
10325       endif
10326 !      call transpose2(a2(1,1),a2t(1,1))
10327
10328 !rc      print *,transp
10329 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10330 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10331
10332       return
10333       end subroutine prodmat3
10334 !-----------------------------------------------------------------------------
10335 ! energy_p_new_barrier.F
10336 !-----------------------------------------------------------------------------
10337       subroutine sum_gradient
10338 !      implicit real*8 (a-h,o-z)
10339       use io_base, only: pdbout
10340 !      include 'DIMENSIONS'
10341 #ifndef ISNAN
10342       external proc_proc
10343 #ifdef WINPGI
10344 !MS$ATTRIBUTES C ::  proc_proc
10345 #endif
10346 #endif
10347 #ifdef MPI
10348       include 'mpif.h'
10349 #endif
10350       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10351                    gloc_scbuf !(3,maxres)
10352
10353       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10354 !#endif
10355 !el local variables
10356       integer :: i,j,k,ierror,ierr
10357       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10358                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10359                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10360                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10361                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10362                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10363                    gsccorr_max,gsccorrx_max,time00
10364
10365 !      include 'COMMON.SETUP'
10366 !      include 'COMMON.IOUNITS'
10367 !      include 'COMMON.FFIELD'
10368 !      include 'COMMON.DERIV'
10369 !      include 'COMMON.INTERACT'
10370 !      include 'COMMON.SBRIDGE'
10371 !      include 'COMMON.CHAIN'
10372 !      include 'COMMON.VAR'
10373 !      include 'COMMON.CONTROL'
10374 !      include 'COMMON.TIME1'
10375 !      include 'COMMON.MAXGRAD'
10376 !      include 'COMMON.SCCOR'
10377 #ifdef TIMING
10378       time01=MPI_Wtime()
10379 #endif
10380 #ifdef DEBUG
10381       write (iout,*) "sum_gradient gvdwc, gvdwx"
10382       do i=1,nres
10383         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10384          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10385       enddo
10386       call flush(iout)
10387 #endif
10388 #ifdef MPI
10389         gradbufc=0.0d0
10390         gradbufx=0.0d0
10391         gradbufc_sum=0.0d0
10392         gloc_scbuf=0.0d0
10393         glocbuf=0.0d0
10394 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10395         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10396           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10397 #endif
10398 !
10399 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10400 !            in virtual-bond-vector coordinates
10401 !
10402 #ifdef DEBUG
10403 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10404 !      do i=1,nres-1
10405 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10406 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10407 !      enddo
10408 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10409 !      do i=1,nres-1
10410 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10411 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10412 !      enddo
10413       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10414       do i=1,nres
10415         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10416          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10417          (gvdwc_scpp(j,i),j=1,3)
10418       enddo
10419       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10420       do i=1,nres
10421         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10422          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10423          (gelc_loc_long(j,i),j=1,3)
10424       enddo
10425       call flush(iout)
10426 #endif
10427 #ifdef SPLITELE
10428       do i=0,nct
10429         do j=1,3
10430           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10431                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10432                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10433                       wel_loc*gel_loc_long(j,i)+ &
10434                       wcorr*gradcorr_long(j,i)+ &
10435                       wcorr5*gradcorr5_long(j,i)+ &
10436                       wcorr6*gradcorr6_long(j,i)+ &
10437                       wturn6*gcorr6_turn_long(j,i)+ &
10438                       wstrain*ghpbc(j,i) &
10439                      +wliptran*gliptranc(j,i) &
10440                      +gradafm(j,i) &
10441                      +welec*gshieldc(j,i) &
10442                      +wcorr*gshieldc_ec(j,i) &
10443                      +wturn3*gshieldc_t3(j,i)&
10444                      +wturn4*gshieldc_t4(j,i)&
10445                      +wel_loc*gshieldc_ll(j,i)&
10446                      +wtube*gg_tube(j,i) &
10447                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10448                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10449                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10450                      wcorr_nucl*gradcorr_nucl(j,i)&
10451                      +wcorr3_nucl*gradcorr3_nucl(j,i)
10452
10453         enddo
10454       enddo
10455 #else
10456       do i=0,nct
10457         do j=1,3
10458           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10459                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10460                       welec*gelc_long(j,i)+ &
10461                       wbond*gradb(j,i)+ &
10462                       wel_loc*gel_loc_long(j,i)+ &
10463                       wcorr*gradcorr_long(j,i)+ &
10464                       wcorr5*gradcorr5_long(j,i)+ &
10465                       wcorr6*gradcorr6_long(j,i)+ &
10466                       wturn6*gcorr6_turn_long(j,i)+ &
10467                       wstrain*ghpbc(j,i) &
10468                      +wliptran*gliptranc(j,i) &
10469                      +gradafm(j,i) &
10470                      +welec*gshieldc(j,i)&
10471                      +wcorr*gshieldc_ec(j,i) &
10472                      +wturn4*gshieldc_t4(j,i) &
10473                      +wel_loc*gshieldc_ll(j,i)&
10474                      +wtube*gg_tube(j,i) &
10475                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10476                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10477                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10478                      wcorr_nucl*gradcorr_nucl(j,i)
10479                      +wcorr3_nucl*gradcorr3_nucl(j,i)
10480         enddo
10481       enddo
10482 #endif
10483 #ifdef MPI
10484       if (nfgtasks.gt.1) then
10485       time00=MPI_Wtime()
10486 #ifdef DEBUG
10487       write (iout,*) "gradbufc before allreduce"
10488       do i=1,nres
10489         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10490       enddo
10491       call flush(iout)
10492 #endif
10493       do i=0,nres
10494         do j=1,3
10495           gradbufc_sum(j,i)=gradbufc(j,i)
10496         enddo
10497       enddo
10498 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10499 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10500 !      time_reduce=time_reduce+MPI_Wtime()-time00
10501 #ifdef DEBUG
10502 !      write (iout,*) "gradbufc_sum after allreduce"
10503 !      do i=1,nres
10504 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10505 !      enddo
10506 !      call flush(iout)
10507 #endif
10508 #ifdef TIMING
10509 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10510 #endif
10511       do i=0,nres
10512         do k=1,3
10513           gradbufc(k,i)=0.0d0
10514         enddo
10515       enddo
10516 #ifdef DEBUG
10517       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10518       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10519                         " jgrad_end  ",jgrad_end(i),&
10520                         i=igrad_start,igrad_end)
10521 #endif
10522 !
10523 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10524 ! do not parallelize this part.
10525 !
10526 !      do i=igrad_start,igrad_end
10527 !        do j=jgrad_start(i),jgrad_end(i)
10528 !          do k=1,3
10529 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10530 !          enddo
10531 !        enddo
10532 !      enddo
10533       do j=1,3
10534         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10535       enddo
10536       do i=nres-2,-1,-1
10537         do j=1,3
10538           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10539         enddo
10540       enddo
10541 #ifdef DEBUG
10542       write (iout,*) "gradbufc after summing"
10543       do i=1,nres
10544         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10545       enddo
10546       call flush(iout)
10547 #endif
10548       else
10549 #endif
10550 !el#define DEBUG
10551 #ifdef DEBUG
10552       write (iout,*) "gradbufc"
10553       do i=1,nres
10554         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10555       enddo
10556       call flush(iout)
10557 #endif
10558 !el#undef DEBUG
10559       do i=-1,nres
10560         do j=1,3
10561           gradbufc_sum(j,i)=gradbufc(j,i)
10562           gradbufc(j,i)=0.0d0
10563         enddo
10564       enddo
10565       do j=1,3
10566         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10567       enddo
10568       do i=nres-2,-1,-1
10569         do j=1,3
10570           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10571         enddo
10572       enddo
10573 !      do i=nnt,nres-1
10574 !        do k=1,3
10575 !          gradbufc(k,i)=0.0d0
10576 !        enddo
10577 !        do j=i+1,nres
10578 !          do k=1,3
10579 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10580 !          enddo
10581 !        enddo
10582 !      enddo
10583 !el#define DEBUG
10584 #ifdef DEBUG
10585       write (iout,*) "gradbufc after summing"
10586       do i=1,nres
10587         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10588       enddo
10589       call flush(iout)
10590 #endif
10591 !el#undef DEBUG
10592 #ifdef MPI
10593       endif
10594 #endif
10595       do k=1,3
10596         gradbufc(k,nres)=0.0d0
10597       enddo
10598 !el----------------
10599 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10600 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10601 !el-----------------
10602       do i=-1,nct
10603         do j=1,3
10604 #ifdef SPLITELE
10605           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10606                       wel_loc*gel_loc(j,i)+ &
10607                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10608                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10609                       wel_loc*gel_loc_long(j,i)+ &
10610                       wcorr*gradcorr_long(j,i)+ &
10611                       wcorr5*gradcorr5_long(j,i)+ &
10612                       wcorr6*gradcorr6_long(j,i)+ &
10613                       wturn6*gcorr6_turn_long(j,i))+ &
10614                       wbond*gradb(j,i)+ &
10615                       wcorr*gradcorr(j,i)+ &
10616                       wturn3*gcorr3_turn(j,i)+ &
10617                       wturn4*gcorr4_turn(j,i)+ &
10618                       wcorr5*gradcorr5(j,i)+ &
10619                       wcorr6*gradcorr6(j,i)+ &
10620                       wturn6*gcorr6_turn(j,i)+ &
10621                       wsccor*gsccorc(j,i) &
10622                      +wscloc*gscloc(j,i)  &
10623                      +wliptran*gliptranc(j,i) &
10624                      +gradafm(j,i) &
10625                      +welec*gshieldc(j,i) &
10626                      +welec*gshieldc_loc(j,i) &
10627                      +wcorr*gshieldc_ec(j,i) &
10628                      +wcorr*gshieldc_loc_ec(j,i) &
10629                      +wturn3*gshieldc_t3(j,i) &
10630                      +wturn3*gshieldc_loc_t3(j,i) &
10631                      +wturn4*gshieldc_t4(j,i) &
10632                      +wturn4*gshieldc_loc_t4(j,i) &
10633                      +wel_loc*gshieldc_ll(j,i) &
10634                      +wel_loc*gshieldc_loc_ll(j,i) &
10635                      +wtube*gg_tube(j,i) &
10636                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10637                      +wvdwpsb*gvdwpsb1(j,i))&
10638                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
10639
10640 !                 if ((i.le.2).and.(i.ge.1))
10641 !                       print *,gradc(j,i,icg),&
10642 !                      gradbufc(j,i),welec*gelc(j,i), &
10643 !                      wel_loc*gel_loc(j,i), &
10644 !                      wscp*gvdwc_scpp(j,i), &
10645 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
10646 !                      wel_loc*gel_loc_long(j,i), &
10647 !                      wcorr*gradcorr_long(j,i), &
10648 !                      wcorr5*gradcorr5_long(j,i), &
10649 !                      wcorr6*gradcorr6_long(j,i), &
10650 !                      wturn6*gcorr6_turn_long(j,i), &
10651 !                      wbond*gradb(j,i), &
10652 !                      wcorr*gradcorr(j,i), &
10653 !                      wturn3*gcorr3_turn(j,i), &
10654 !                      wturn4*gcorr4_turn(j,i), &
10655 !                      wcorr5*gradcorr5(j,i), &
10656 !                      wcorr6*gradcorr6(j,i), &
10657 !                      wturn6*gcorr6_turn(j,i), &
10658 !                      wsccor*gsccorc(j,i) &
10659 !                     ,wscloc*gscloc(j,i)  &
10660 !                     ,wliptran*gliptranc(j,i) &
10661 !                    ,gradafm(j,i) &
10662 !                     ,welec*gshieldc(j,i) &
10663 !                     ,welec*gshieldc_loc(j,i) &
10664 !                     ,wcorr*gshieldc_ec(j,i) &
10665 !                     ,wcorr*gshieldc_loc_ec(j,i) &
10666 !                     ,wturn3*gshieldc_t3(j,i) &
10667 !                     ,wturn3*gshieldc_loc_t3(j,i) &
10668 !                     ,wturn4*gshieldc_t4(j,i) &
10669 !                     ,wturn4*gshieldc_loc_t4(j,i) &
10670 !                     ,wel_loc*gshieldc_ll(j,i) &
10671 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
10672 !                     ,wtube*gg_tube(j,i) &
10673 !                     ,wbond_nucl*gradb_nucl(j,i) &
10674 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
10675 !                     wvdwpsb*gvdwpsb1(j,i)&
10676 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
10677 !
10678
10679 #else
10680           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10681                       wel_loc*gel_loc(j,i)+ &
10682                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10683                       welec*gelc_long(j,i)+ &
10684                       wel_loc*gel_loc_long(j,i)+ &
10685 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10686                       wcorr5*gradcorr5_long(j,i)+ &
10687                       wcorr6*gradcorr6_long(j,i)+ &
10688                       wturn6*gcorr6_turn_long(j,i))+ &
10689                       wbond*gradb(j,i)+ &
10690                       wcorr*gradcorr(j,i)+ &
10691                       wturn3*gcorr3_turn(j,i)+ &
10692                       wturn4*gcorr4_turn(j,i)+ &
10693                       wcorr5*gradcorr5(j,i)+ &
10694                       wcorr6*gradcorr6(j,i)+ &
10695                       wturn6*gcorr6_turn(j,i)+ &
10696                       wsccor*gsccorc(j,i) &
10697                      +wscloc*gscloc(j,i) &
10698                      +gradafm(j,i) &
10699                      +wliptran*gliptranc(j,i) &
10700                      +welec*gshieldc(j,i) &
10701                      +welec*gshieldc_loc(j,) &
10702                      +wcorr*gshieldc_ec(j,i) &
10703                      +wcorr*gshieldc_loc_ec(j,i) &
10704                      +wturn3*gshieldc_t3(j,i) &
10705                      +wturn3*gshieldc_loc_t3(j,i) &
10706                      +wturn4*gshieldc_t4(j,i) &
10707                      +wturn4*gshieldc_loc_t4(j,i) &
10708                      +wel_loc*gshieldc_ll(j,i) &
10709                      +wel_loc*gshieldc_loc_ll(j,i) &
10710                      +wtube*gg_tube(j,i) &
10711                      +wbond_nucl*gradb_nucl(j,i) &
10712                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10713                      +wvdwpsb*gvdwpsb1(j,i))&
10714                      +wsbloc*gsbloc(j,i)
10715
10716
10717
10718
10719 #endif
10720           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10721                         wbond*gradbx(j,i)+ &
10722                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10723                         wsccor*gsccorx(j,i) &
10724                        +wscloc*gsclocx(j,i) &
10725                        +wliptran*gliptranx(j,i) &
10726                        +welec*gshieldx(j,i)     &
10727                        +wcorr*gshieldx_ec(j,i)  &
10728                        +wturn3*gshieldx_t3(j,i) &
10729                        +wturn4*gshieldx_t4(j,i) &
10730                        +wel_loc*gshieldx_ll(j,i)&
10731                        +wtube*gg_tube_sc(j,i)   &
10732                        +wbond_nucl*gradbx_nucl(j,i) &
10733                        +wvdwsb*gvdwsbx(j,i) &
10734                        +welsb*gelsbx(j,i) &
10735                        +wcorr_nucl*gradxorr_nucl(j,i)&
10736                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
10737                        +wsbloc*gsblocx(j,i)
10738         enddo
10739       enddo
10740 #ifdef DEBUG
10741       write (iout,*) "gloc before adding corr"
10742       do i=1,4*nres
10743         write (iout,*) i,gloc(i,icg)
10744       enddo
10745 #endif
10746       do i=1,nres-3
10747         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10748          +wcorr5*g_corr5_loc(i) &
10749          +wcorr6*g_corr6_loc(i) &
10750          +wturn4*gel_loc_turn4(i) &
10751          +wturn3*gel_loc_turn3(i) &
10752          +wturn6*gel_loc_turn6(i) &
10753          +wel_loc*gel_loc_loc(i)
10754       enddo
10755 #ifdef DEBUG
10756       write (iout,*) "gloc after adding corr"
10757       do i=1,4*nres
10758         write (iout,*) i,gloc(i,icg)
10759       enddo
10760 #endif
10761 #ifdef MPI
10762       if (nfgtasks.gt.1) then
10763         do j=1,3
10764           do i=0,nres
10765             gradbufc(j,i)=gradc(j,i,icg)
10766             gradbufx(j,i)=gradx(j,i,icg)
10767           enddo
10768         enddo
10769         do i=1,4*nres
10770           glocbuf(i)=gloc(i,icg)
10771         enddo
10772 !#define DEBUG
10773 #ifdef DEBUG
10774       write (iout,*) "gloc_sc before reduce"
10775       do i=1,nres
10776        do j=1,1
10777         write (iout,*) i,j,gloc_sc(j,i,icg)
10778        enddo
10779       enddo
10780 #endif
10781 !#undef DEBUG
10782         do i=1,nres
10783          do j=1,3
10784           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10785          enddo
10786         enddo
10787         time00=MPI_Wtime()
10788         call MPI_Barrier(FG_COMM,IERR)
10789         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10790         time00=MPI_Wtime()
10791         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10792           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10793         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
10794           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10795         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10796           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10797         time_reduce=time_reduce+MPI_Wtime()-time00
10798         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10799           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10800         time_reduce=time_reduce+MPI_Wtime()-time00
10801 !#define DEBUG
10802 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
10803 #ifdef DEBUG
10804       write (iout,*) "gloc_sc after reduce"
10805       do i=1,nres
10806        do j=1,1
10807         write (iout,*) i,j,gloc_sc(j,i,icg)
10808        enddo
10809       enddo
10810 #endif
10811 !#undef DEBUG
10812 #ifdef DEBUG
10813       write (iout,*) "gloc after reduce"
10814       do i=1,4*nres
10815         write (iout,*) i,gloc(i,icg)
10816       enddo
10817 #endif
10818       endif
10819 #endif
10820       if (gnorm_check) then
10821 !
10822 ! Compute the maximum elements of the gradient
10823 !
10824       gvdwc_max=0.0d0
10825       gvdwc_scp_max=0.0d0
10826       gelc_max=0.0d0
10827       gvdwpp_max=0.0d0
10828       gradb_max=0.0d0
10829       ghpbc_max=0.0d0
10830       gradcorr_max=0.0d0
10831       gel_loc_max=0.0d0
10832       gcorr3_turn_max=0.0d0
10833       gcorr4_turn_max=0.0d0
10834       gradcorr5_max=0.0d0
10835       gradcorr6_max=0.0d0
10836       gcorr6_turn_max=0.0d0
10837       gsccorc_max=0.0d0
10838       gscloc_max=0.0d0
10839       gvdwx_max=0.0d0
10840       gradx_scp_max=0.0d0
10841       ghpbx_max=0.0d0
10842       gradxorr_max=0.0d0
10843       gsccorx_max=0.0d0
10844       gsclocx_max=0.0d0
10845       do i=1,nct
10846         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10847         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10848         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10849         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10850          gvdwc_scp_max=gvdwc_scp_norm
10851         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10852         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10853         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10854         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10855         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10856         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10857         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10858         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10859         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10860         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10861         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10862         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10863         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10864           gcorr3_turn(1,i)))
10865         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10866           gcorr3_turn_max=gcorr3_turn_norm
10867         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10868           gcorr4_turn(1,i)))
10869         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10870           gcorr4_turn_max=gcorr4_turn_norm
10871         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10872         if (gradcorr5_norm.gt.gradcorr5_max) &
10873           gradcorr5_max=gradcorr5_norm
10874         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10875         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10876         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10877           gcorr6_turn(1,i)))
10878         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10879           gcorr6_turn_max=gcorr6_turn_norm
10880         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
10881         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
10882         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
10883         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
10884         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
10885         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
10886         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
10887         if (gradx_scp_norm.gt.gradx_scp_max) &
10888           gradx_scp_max=gradx_scp_norm
10889         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
10890         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
10891         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
10892         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
10893         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
10894         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
10895         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
10896         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
10897       enddo
10898       if (gradout) then
10899 #ifdef AIX
10900         open(istat,file=statname,position="append")
10901 #else
10902         open(istat,file=statname,access="append")
10903 #endif
10904         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
10905            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
10906            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
10907            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
10908            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
10909            gsccorx_max,gsclocx_max
10910         close(istat)
10911         if (gvdwc_max.gt.1.0d4) then
10912           write (iout,*) "gvdwc gvdwx gradb gradbx"
10913           do i=nnt,nct
10914             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
10915               gradb(j,i),gradbx(j,i),j=1,3)
10916           enddo
10917           call pdbout(0.0d0,'cipiszcze',iout)
10918           call flush(iout)
10919         endif
10920       endif
10921       endif
10922 !el#define DEBUG
10923 #ifdef DEBUG
10924       write (iout,*) "gradc gradx gloc"
10925       do i=1,nres
10926         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
10927          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
10928       enddo
10929 #endif
10930 !el#undef DEBUG
10931 #ifdef TIMING
10932       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
10933 #endif
10934       return
10935       end subroutine sum_gradient
10936 !-----------------------------------------------------------------------------
10937       subroutine sc_grad
10938 !      implicit real*8 (a-h,o-z)
10939       use calc_data
10940 !      include 'DIMENSIONS'
10941 !      include 'COMMON.CHAIN'
10942 !      include 'COMMON.DERIV'
10943 !      include 'COMMON.CALC'
10944 !      include 'COMMON.IOUNITS'
10945       real(kind=8), dimension(3) :: dcosom1,dcosom2
10946 !      print *,"wchodze"
10947       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
10948       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
10949       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
10950            -2.0D0*alf12*eps3der+sigder*sigsq_om12
10951 ! diagnostics only
10952 !      eom1=0.0d0
10953 !      eom2=0.0d0
10954 !      eom12=evdwij*eps1_om12
10955 ! end diagnostics
10956 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
10957 !       " sigder",sigder
10958 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
10959 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
10960 !C      print *,sss_ele_cut,'in sc_grad'
10961       do k=1,3
10962         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
10963         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
10964       enddo
10965       do k=1,3
10966         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
10967 !C      print *,'gg',k,gg(k)
10968        enddo
10969 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
10970 !      write (iout,*) "gg",(gg(k),k=1,3)
10971       do k=1,3
10972         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
10973                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10974                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
10975                   *sss_ele_cut
10976
10977         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
10978                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10979                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
10980                   *sss_ele_cut
10981
10982 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10983 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
10984 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10985 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
10986       enddo
10987 !
10988 ! Calculate the components of the gradient in DC and X
10989 !
10990 !grad      do k=i,j-1
10991 !grad        do l=1,3
10992 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
10993 !grad        enddo
10994 !grad      enddo
10995       do l=1,3
10996         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
10997         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
10998       enddo
10999       return
11000       end subroutine sc_grad
11001 #ifdef CRYST_THETA
11002 !-----------------------------------------------------------------------------
11003       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11004
11005       use comm_calcthet
11006 !      implicit real*8 (a-h,o-z)
11007 !      include 'DIMENSIONS'
11008 !      include 'COMMON.LOCAL'
11009 !      include 'COMMON.IOUNITS'
11010 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11011 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11012 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11013       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11014       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11015 !el      integer :: it
11016 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11017 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11018 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11019 !el local variables
11020
11021       delthec=thetai-thet_pred_mean
11022       delthe0=thetai-theta0i
11023 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11024       t3 = thetai-thet_pred_mean
11025       t6 = t3**2
11026       t9 = term1
11027       t12 = t3*sigcsq
11028       t14 = t12+t6*sigsqtc
11029       t16 = 1.0d0
11030       t21 = thetai-theta0i
11031       t23 = t21**2
11032       t26 = term2
11033       t27 = t21*t26
11034       t32 = termexp
11035       t40 = t32**2
11036       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11037        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11038        *(-t12*t9-ak*sig0inv*t27)
11039       return
11040       end subroutine mixder
11041 #endif
11042 !-----------------------------------------------------------------------------
11043 ! cartder.F
11044 !-----------------------------------------------------------------------------
11045       subroutine cartder
11046 !-----------------------------------------------------------------------------
11047 ! This subroutine calculates the derivatives of the consecutive virtual
11048 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11049 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11050 ! in the angles alpha and omega, describing the location of a side chain
11051 ! in its local coordinate system.
11052 !
11053 ! The derivatives are stored in the following arrays:
11054 !
11055 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11056 ! The structure is as follows:
11057 !
11058 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11059 ! 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)
11060 !         . . . . . . . . . . . .  . . . . . .
11061 ! 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)
11062 !                          .
11063 !                          .
11064 !                          .
11065 ! 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)
11066 !
11067 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11068 ! The structure is same as above.
11069 !
11070 ! DCDS - the derivatives of the side chain vectors in the local spherical
11071 ! andgles alph and omega:
11072 !
11073 ! 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)
11074 ! 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)
11075 !                          .
11076 !                          .
11077 !                          .
11078 ! 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)
11079 !
11080 ! Version of March '95, based on an early version of November '91.
11081 !
11082 !**********************************************************************
11083 !      implicit real*8 (a-h,o-z)
11084 !      include 'DIMENSIONS'
11085 !      include 'COMMON.VAR'
11086 !      include 'COMMON.CHAIN'
11087 !      include 'COMMON.DERIV'
11088 !      include 'COMMON.GEO'
11089 !      include 'COMMON.LOCAL'
11090 !      include 'COMMON.INTERACT'
11091       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11092       real(kind=8),dimension(3,3) :: dp,temp
11093 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11094       real(kind=8),dimension(3) :: xx,xx1
11095 !el local variables
11096       integer :: i,k,l,j,m,ind,ind1,jjj
11097       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11098                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11099                  sint2,xp,yp,xxp,yyp,zzp,dj
11100
11101 !      common /przechowalnia/ fromto
11102       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11103 ! get the position of the jth ijth fragment of the chain coordinate system
11104 ! in the fromto array.
11105 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11106 !
11107 !      maxdim=(nres-1)*(nres-2)/2
11108 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11109 ! calculate the derivatives of transformation matrix elements in theta
11110 !
11111
11112 !el      call flush(iout) !el
11113       do i=1,nres-2
11114         rdt(1,1,i)=-rt(1,2,i)
11115         rdt(1,2,i)= rt(1,1,i)
11116         rdt(1,3,i)= 0.0d0
11117         rdt(2,1,i)=-rt(2,2,i)
11118         rdt(2,2,i)= rt(2,1,i)
11119         rdt(2,3,i)= 0.0d0
11120         rdt(3,1,i)=-rt(3,2,i)
11121         rdt(3,2,i)= rt(3,1,i)
11122         rdt(3,3,i)= 0.0d0
11123       enddo
11124 !
11125 ! derivatives in phi
11126 !
11127       do i=2,nres-2
11128         drt(1,1,i)= 0.0d0
11129         drt(1,2,i)= 0.0d0
11130         drt(1,3,i)= 0.0d0
11131         drt(2,1,i)= rt(3,1,i)
11132         drt(2,2,i)= rt(3,2,i)
11133         drt(2,3,i)= rt(3,3,i)
11134         drt(3,1,i)=-rt(2,1,i)
11135         drt(3,2,i)=-rt(2,2,i)
11136         drt(3,3,i)=-rt(2,3,i)
11137       enddo
11138 !
11139 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11140 !
11141       do i=2,nres-2
11142         ind=indmat(i,i+1)
11143         do k=1,3
11144           do l=1,3
11145             temp(k,l)=rt(k,l,i)
11146           enddo
11147         enddo
11148         do k=1,3
11149           do l=1,3
11150             fromto(k,l,ind)=temp(k,l)
11151           enddo
11152         enddo
11153         do j=i+1,nres-2
11154           ind=indmat(i,j+1)
11155           do k=1,3
11156             do l=1,3
11157               dpkl=0.0d0
11158               do m=1,3
11159                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11160               enddo
11161               dp(k,l)=dpkl
11162               fromto(k,l,ind)=dpkl
11163             enddo
11164           enddo
11165           do k=1,3
11166             do l=1,3
11167               temp(k,l)=dp(k,l)
11168             enddo
11169           enddo
11170         enddo
11171       enddo
11172 !
11173 ! Calculate derivatives.
11174 !
11175       ind1=0
11176       do i=1,nres-2
11177       ind1=ind1+1
11178 !
11179 ! Derivatives of DC(i+1) in theta(i+2)
11180 !
11181         do j=1,3
11182           do k=1,2
11183             dpjk=0.0D0
11184             do l=1,3
11185               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11186             enddo
11187             dp(j,k)=dpjk
11188             prordt(j,k,i)=dp(j,k)
11189           enddo
11190           dp(j,3)=0.0D0
11191           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11192         enddo
11193 !
11194 ! Derivatives of SC(i+1) in theta(i+2)
11195 !
11196         xx1(1)=-0.5D0*xloc(2,i+1)
11197         xx1(2)= 0.5D0*xloc(1,i+1)
11198         do j=1,3
11199           xj=0.0D0
11200           do k=1,2
11201             xj=xj+r(j,k,i)*xx1(k)
11202           enddo
11203           xx(j)=xj
11204         enddo
11205         do j=1,3
11206           rj=0.0D0
11207           do k=1,3
11208             rj=rj+prod(j,k,i)*xx(k)
11209           enddo
11210           dxdv(j,ind1)=rj
11211         enddo
11212 !
11213 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11214 ! than the other off-diagonal derivatives.
11215 !
11216         do j=1,3
11217           dxoiij=0.0D0
11218           do k=1,3
11219             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11220           enddo
11221           dxdv(j,ind1+1)=dxoiij
11222         enddo
11223 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11224 !
11225 ! Derivatives of DC(i+1) in phi(i+2)
11226 !
11227         do j=1,3
11228           do k=1,3
11229             dpjk=0.0
11230             do l=2,3
11231               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11232             enddo
11233             dp(j,k)=dpjk
11234             prodrt(j,k,i)=dp(j,k)
11235           enddo
11236           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11237         enddo
11238 !
11239 ! Derivatives of SC(i+1) in phi(i+2)
11240 !
11241         xx(1)= 0.0D0
11242         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11243         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11244         do j=1,3
11245           rj=0.0D0
11246           do k=2,3
11247             rj=rj+prod(j,k,i)*xx(k)
11248           enddo
11249           dxdv(j+3,ind1)=-rj
11250         enddo
11251 !
11252 ! Derivatives of SC(i+1) in phi(i+3).
11253 !
11254         do j=1,3
11255           dxoiij=0.0D0
11256           do k=1,3
11257             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11258           enddo
11259           dxdv(j+3,ind1+1)=dxoiij
11260         enddo
11261 !
11262 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11263 ! theta(nres) and phi(i+3) thru phi(nres).
11264 !
11265         do j=i+1,nres-2
11266         ind1=ind1+1
11267         ind=indmat(i+1,j+1)
11268 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11269           do k=1,3
11270             do l=1,3
11271               tempkl=0.0D0
11272               do m=1,2
11273                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11274               enddo
11275               temp(k,l)=tempkl
11276             enddo
11277           enddo
11278 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11279 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11280 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11281 ! Derivatives of virtual-bond vectors in theta
11282           do k=1,3
11283             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11284           enddo
11285 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11286 ! Derivatives of SC vectors in theta
11287           do k=1,3
11288             dxoijk=0.0D0
11289             do l=1,3
11290               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11291             enddo
11292             dxdv(k,ind1+1)=dxoijk
11293           enddo
11294 !
11295 !--- Calculate the derivatives in phi
11296 !
11297           do k=1,3
11298             do l=1,3
11299               tempkl=0.0D0
11300               do m=1,3
11301                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11302               enddo
11303               temp(k,l)=tempkl
11304             enddo
11305           enddo
11306           do k=1,3
11307             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11308         enddo
11309           do k=1,3
11310             dxoijk=0.0D0
11311             do l=1,3
11312               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11313             enddo
11314             dxdv(k+3,ind1+1)=dxoijk
11315           enddo
11316         enddo
11317       enddo
11318 !
11319 ! Derivatives in alpha and omega:
11320 !
11321       do i=2,nres-1
11322 !       dsci=dsc(itype(i,1))
11323         dsci=vbld(i+nres)
11324 #ifdef OSF
11325         alphi=alph(i)
11326         omegi=omeg(i)
11327         if(alphi.ne.alphi) alphi=100.0
11328         if(omegi.ne.omegi) omegi=-100.0
11329 #else
11330       alphi=alph(i)
11331       omegi=omeg(i)
11332 #endif
11333 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11334       cosalphi=dcos(alphi)
11335       sinalphi=dsin(alphi)
11336       cosomegi=dcos(omegi)
11337       sinomegi=dsin(omegi)
11338       temp(1,1)=-dsci*sinalphi
11339       temp(2,1)= dsci*cosalphi*cosomegi
11340       temp(3,1)=-dsci*cosalphi*sinomegi
11341       temp(1,2)=0.0D0
11342       temp(2,2)=-dsci*sinalphi*sinomegi
11343       temp(3,2)=-dsci*sinalphi*cosomegi
11344       theta2=pi-0.5D0*theta(i+1)
11345       cost2=dcos(theta2)
11346       sint2=dsin(theta2)
11347       jjj=0
11348 !d      print *,((temp(l,k),l=1,3),k=1,2)
11349         do j=1,2
11350         xp=temp(1,j)
11351         yp=temp(2,j)
11352         xxp= xp*cost2+yp*sint2
11353         yyp=-xp*sint2+yp*cost2
11354         zzp=temp(3,j)
11355         xx(1)=xxp
11356         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11357         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11358         do k=1,3
11359           dj=0.0D0
11360           do l=1,3
11361             dj=dj+prod(k,l,i-1)*xx(l)
11362             enddo
11363           dxds(jjj+k,i)=dj
11364           enddo
11365         jjj=jjj+3
11366       enddo
11367       enddo
11368       return
11369       end subroutine cartder
11370 !-----------------------------------------------------------------------------
11371 ! checkder_p.F
11372 !-----------------------------------------------------------------------------
11373       subroutine check_cartgrad
11374 ! Check the gradient of Cartesian coordinates in internal coordinates.
11375 !      implicit real*8 (a-h,o-z)
11376 !      include 'DIMENSIONS'
11377 !      include 'COMMON.IOUNITS'
11378 !      include 'COMMON.VAR'
11379 !      include 'COMMON.CHAIN'
11380 !      include 'COMMON.GEO'
11381 !      include 'COMMON.LOCAL'
11382 !      include 'COMMON.DERIV'
11383       real(kind=8),dimension(6,nres) :: temp
11384       real(kind=8),dimension(3) :: xx,gg
11385       integer :: i,k,j,ii
11386       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11387 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11388 !
11389 ! Check the gradient of the virtual-bond and SC vectors in the internal
11390 ! coordinates.
11391 !
11392       aincr=1.0d-6
11393       aincr2=5.0d-7
11394       call cartder
11395       write (iout,'(a)') '**************** dx/dalpha'
11396       write (iout,'(a)')
11397       do i=2,nres-1
11398       alphi=alph(i)
11399       alph(i)=alph(i)+aincr
11400       do k=1,3
11401         temp(k,i)=dc(k,nres+i)
11402         enddo
11403       call chainbuild
11404       do k=1,3
11405         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11406         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11407         enddo
11408         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11409         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11410         write (iout,'(a)')
11411       alph(i)=alphi
11412       call chainbuild
11413       enddo
11414       write (iout,'(a)')
11415       write (iout,'(a)') '**************** dx/domega'
11416       write (iout,'(a)')
11417       do i=2,nres-1
11418       omegi=omeg(i)
11419       omeg(i)=omeg(i)+aincr
11420       do k=1,3
11421         temp(k,i)=dc(k,nres+i)
11422         enddo
11423       call chainbuild
11424       do k=1,3
11425           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11426           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11427                 (aincr*dabs(dxds(k+3,i))+aincr))
11428         enddo
11429         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11430             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11431         write (iout,'(a)')
11432       omeg(i)=omegi
11433       call chainbuild
11434       enddo
11435       write (iout,'(a)')
11436       write (iout,'(a)') '**************** dx/dtheta'
11437       write (iout,'(a)')
11438       do i=3,nres
11439       theti=theta(i)
11440         theta(i)=theta(i)+aincr
11441         do j=i-1,nres-1
11442           do k=1,3
11443             temp(k,j)=dc(k,nres+j)
11444           enddo
11445         enddo
11446         call chainbuild
11447         do j=i-1,nres-1
11448         ii = indmat(i-2,j)
11449 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11450         do k=1,3
11451           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11452           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11453                   (aincr*dabs(dxdv(k,ii))+aincr))
11454           enddo
11455           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11456               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11457           write(iout,'(a)')
11458         enddo
11459         write (iout,'(a)')
11460         theta(i)=theti
11461         call chainbuild
11462       enddo
11463       write (iout,'(a)') '***************** dx/dphi'
11464       write (iout,'(a)')
11465       do i=4,nres
11466         phi(i)=phi(i)+aincr
11467         do j=i-1,nres-1
11468           do k=1,3
11469             temp(k,j)=dc(k,nres+j)
11470           enddo
11471         enddo
11472         call chainbuild
11473         do j=i-1,nres-1
11474         ii = indmat(i-2,j)
11475 !         print *,'ii=',ii
11476         do k=1,3
11477           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11478             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11479                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11480           enddo
11481           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11482               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11483           write(iout,'(a)')
11484         enddo
11485         phi(i)=phi(i)-aincr
11486         call chainbuild
11487       enddo
11488       write (iout,'(a)') '****************** ddc/dtheta'
11489       do i=1,nres-2
11490         thet=theta(i+2)
11491         theta(i+2)=thet+aincr
11492         do j=i,nres
11493           do k=1,3
11494             temp(k,j)=dc(k,j)
11495           enddo
11496         enddo
11497         call chainbuild
11498         do j=i+1,nres-1
11499         ii = indmat(i,j)
11500 !         print *,'ii=',ii
11501         do k=1,3
11502           gg(k)=(dc(k,j)-temp(k,j))/aincr
11503           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11504                  (aincr*dabs(dcdv(k,ii))+aincr))
11505           enddo
11506           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11507                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11508         write (iout,'(a)')
11509         enddo
11510         do j=1,nres
11511           do k=1,3
11512             dc(k,j)=temp(k,j)
11513           enddo
11514         enddo
11515         theta(i+2)=thet
11516       enddo
11517       write (iout,'(a)') '******************* ddc/dphi'
11518       do i=1,nres-3
11519         phii=phi(i+3)
11520         phi(i+3)=phii+aincr
11521         do j=1,nres
11522           do k=1,3
11523             temp(k,j)=dc(k,j)
11524           enddo
11525         enddo
11526         call chainbuild
11527         do j=i+2,nres-1
11528         ii = indmat(i+1,j)
11529 !         print *,'ii=',ii
11530         do k=1,3
11531           gg(k)=(dc(k,j)-temp(k,j))/aincr
11532             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11533                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11534           enddo
11535           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11536                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11537         write (iout,'(a)')
11538         enddo
11539         do j=1,nres
11540           do k=1,3
11541             dc(k,j)=temp(k,j)
11542           enddo
11543         enddo
11544         phi(i+3)=phii
11545       enddo
11546       return
11547       end subroutine check_cartgrad
11548 !-----------------------------------------------------------------------------
11549       subroutine check_ecart
11550 ! Check the gradient of the energy in Cartesian coordinates.
11551 !     implicit real*8 (a-h,o-z)
11552 !     include 'DIMENSIONS'
11553 !     include 'COMMON.CHAIN'
11554 !     include 'COMMON.DERIV'
11555 !     include 'COMMON.IOUNITS'
11556 !     include 'COMMON.VAR'
11557 !     include 'COMMON.CONTACTS'
11558       use comm_srutu
11559 !el      integer :: icall
11560 !el      common /srutu/ icall
11561       real(kind=8),dimension(6) :: ggg
11562       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11563       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11564       real(kind=8),dimension(6,nres) :: grad_s
11565       real(kind=8),dimension(0:n_ene) :: energia,energia1
11566       integer :: uiparm(1)
11567       real(kind=8) :: urparm(1)
11568 !EL      external fdum
11569       integer :: nf,i,j,k
11570       real(kind=8) :: aincr,etot,etot1
11571       icg=1
11572       nf=0
11573       nfl=0
11574       call zerograd
11575       aincr=1.0D-5
11576       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11577       nf=0
11578       icall=0
11579       call geom_to_var(nvar,x)
11580       call etotal(energia)
11581       etot=energia(0)
11582 !el      call enerprint(energia)
11583       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11584       icall =1
11585       do i=1,nres
11586         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11587       enddo
11588       do i=1,nres
11589       do j=1,3
11590         grad_s(j,i)=gradc(j,i,icg)
11591         grad_s(j+3,i)=gradx(j,i,icg)
11592         enddo
11593       enddo
11594       call flush(iout)
11595       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11596       do i=1,nres
11597         do j=1,3
11598         xx(j)=c(j,i+nres)
11599         ddc(j)=dc(j,i)
11600         ddx(j)=dc(j,i+nres)
11601         enddo
11602       do j=1,3
11603         dc(j,i)=dc(j,i)+aincr
11604         do k=i+1,nres
11605           c(j,k)=c(j,k)+aincr
11606           c(j,k+nres)=c(j,k+nres)+aincr
11607           enddo
11608           call etotal(energia1)
11609           etot1=energia1(0)
11610         ggg(j)=(etot1-etot)/aincr
11611         dc(j,i)=ddc(j)
11612         do k=i+1,nres
11613           c(j,k)=c(j,k)-aincr
11614           c(j,k+nres)=c(j,k+nres)-aincr
11615           enddo
11616         enddo
11617       do j=1,3
11618         c(j,i+nres)=c(j,i+nres)+aincr
11619         dc(j,i+nres)=dc(j,i+nres)+aincr
11620           call etotal(energia1)
11621           etot1=energia1(0)
11622         ggg(j+3)=(etot1-etot)/aincr
11623         c(j,i+nres)=xx(j)
11624         dc(j,i+nres)=ddx(j)
11625         enddo
11626       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11627          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11628       enddo
11629       return
11630       end subroutine check_ecart
11631 #ifdef CARGRAD
11632 !-----------------------------------------------------------------------------
11633       subroutine check_ecartint
11634 ! Check the gradient of the energy in Cartesian coordinates.
11635       use io_base, only: intout
11636 !      implicit real*8 (a-h,o-z)
11637 !      include 'DIMENSIONS'
11638 !      include 'COMMON.CONTROL'
11639 !      include 'COMMON.CHAIN'
11640 !      include 'COMMON.DERIV'
11641 !      include 'COMMON.IOUNITS'
11642 !      include 'COMMON.VAR'
11643 !      include 'COMMON.CONTACTS'
11644 !      include 'COMMON.MD'
11645 !      include 'COMMON.LOCAL'
11646 !      include 'COMMON.SPLITELE'
11647       use comm_srutu
11648 !el      integer :: icall
11649 !el      common /srutu/ icall
11650       real(kind=8),dimension(6) :: ggg,ggg1
11651       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11652       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11653       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11654       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11655       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11656       real(kind=8),dimension(0:n_ene) :: energia,energia1
11657       integer :: uiparm(1)
11658       real(kind=8) :: urparm(1)
11659 !EL      external fdum
11660       integer :: i,j,k,nf
11661       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11662                    etot21,etot22
11663       r_cut=2.0d0
11664       rlambd=0.3d0
11665       icg=1
11666       nf=0
11667       nfl=0
11668       call intout
11669 !      call intcartderiv
11670 !      call checkintcartgrad
11671       call zerograd
11672       aincr=1.0D-5
11673       write(iout,*) 'Calling CHECK_ECARTINT.'
11674       nf=0
11675       icall=0
11676       write (iout,*) "Before geom_to_var"
11677       call geom_to_var(nvar,x)
11678       write (iout,*) "after geom_to_var"
11679       write (iout,*) "split_ene ",split_ene
11680       call flush(iout)
11681       if (.not.split_ene) then
11682         write(iout,*) 'Calling CHECK_ECARTINT if'
11683         call etotal(energia)
11684 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11685         etot=energia(0)
11686         write (iout,*) "etot",etot
11687         call flush(iout)
11688 !el        call enerprint(energia)
11689 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11690         call flush(iout)
11691         write (iout,*) "enter cartgrad"
11692         call flush(iout)
11693         call cartgrad
11694 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11695         write (iout,*) "exit cartgrad"
11696         call flush(iout)
11697         icall =1
11698         do i=1,nres
11699           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11700         enddo
11701         do j=1,3
11702           grad_s(j,0)=gcart(j,0)
11703         enddo
11704 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11705         do i=1,nres
11706           do j=1,3
11707             grad_s(j,i)=gcart(j,i)
11708             grad_s(j+3,i)=gxcart(j,i)
11709           enddo
11710         enddo
11711       else
11712 write(iout,*) 'Calling CHECK_ECARTIN else.'
11713 !- split gradient check
11714         call zerograd
11715         call etotal_long(energia)
11716 !el        call enerprint(energia)
11717         call flush(iout)
11718         write (iout,*) "enter cartgrad"
11719         call flush(iout)
11720         call cartgrad
11721         write (iout,*) "exit cartgrad"
11722         call flush(iout)
11723         icall =1
11724         write (iout,*) "longrange grad"
11725         do i=1,nres
11726           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11727           (gxcart(j,i),j=1,3)
11728         enddo
11729         do j=1,3
11730           grad_s(j,0)=gcart(j,0)
11731         enddo
11732         do i=1,nres
11733           do j=1,3
11734             grad_s(j,i)=gcart(j,i)
11735             grad_s(j+3,i)=gxcart(j,i)
11736           enddo
11737         enddo
11738         call zerograd
11739         call etotal_short(energia)
11740         call enerprint(energia)
11741         call flush(iout)
11742         write (iout,*) "enter cartgrad"
11743         call flush(iout)
11744         call cartgrad
11745         write (iout,*) "exit cartgrad"
11746         call flush(iout)
11747         icall =1
11748         write (iout,*) "shortrange grad"
11749         do i=1,nres
11750           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11751           (gxcart(j,i),j=1,3)
11752         enddo
11753         do j=1,3
11754           grad_s1(j,0)=gcart(j,0)
11755         enddo
11756         do i=1,nres
11757           do j=1,3
11758             grad_s1(j,i)=gcart(j,i)
11759             grad_s1(j+3,i)=gxcart(j,i)
11760           enddo
11761         enddo
11762       endif
11763       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11764 !      do i=1,nres
11765       do i=nnt,nct
11766         do j=1,3
11767           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11768           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11769         ddc(j)=c(j,i)
11770         ddx(j)=c(j,i+nres)
11771           dcnorm_safe1(j)=dc_norm(j,i-1)
11772           dcnorm_safe2(j)=dc_norm(j,i)
11773           dxnorm_safe(j)=dc_norm(j,i+nres)
11774         enddo
11775       do j=1,3
11776         c(j,i)=ddc(j)+aincr
11777           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11778           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11779           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11780           dc(j,i)=c(j,i+1)-c(j,i)
11781           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11782           call int_from_cart1(.false.)
11783           if (.not.split_ene) then
11784             call etotal(energia1)
11785             etot1=energia1(0)
11786             write (iout,*) "ij",i,j," etot1",etot1
11787           else
11788 !- split gradient
11789             call etotal_long(energia1)
11790             etot11=energia1(0)
11791             call etotal_short(energia1)
11792             etot12=energia1(0)
11793           endif
11794 !- end split gradient
11795 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11796         c(j,i)=ddc(j)-aincr
11797           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11798           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11799           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11800           dc(j,i)=c(j,i+1)-c(j,i)
11801           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11802           call int_from_cart1(.false.)
11803           if (.not.split_ene) then
11804             call etotal(energia1)
11805             etot2=energia1(0)
11806             write (iout,*) "ij",i,j," etot2",etot2
11807           ggg(j)=(etot1-etot2)/(2*aincr)
11808           else
11809 !- split gradient
11810             call etotal_long(energia1)
11811             etot21=energia1(0)
11812           ggg(j)=(etot11-etot21)/(2*aincr)
11813             call etotal_short(energia1)
11814             etot22=energia1(0)
11815           ggg1(j)=(etot12-etot22)/(2*aincr)
11816 !- end split gradient
11817 !            write (iout,*) "etot21",etot21," etot22",etot22
11818           endif
11819 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11820         c(j,i)=ddc(j)
11821           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11822           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11823           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11824           dc(j,i)=c(j,i+1)-c(j,i)
11825           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11826           dc_norm(j,i-1)=dcnorm_safe1(j)
11827           dc_norm(j,i)=dcnorm_safe2(j)
11828           dc_norm(j,i+nres)=dxnorm_safe(j)
11829         enddo
11830       do j=1,3
11831         c(j,i+nres)=ddx(j)+aincr
11832           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11833           call int_from_cart1(.false.)
11834           if (.not.split_ene) then
11835             call etotal(energia1)
11836             etot1=energia1(0)
11837           else
11838 !- split gradient
11839             call etotal_long(energia1)
11840             etot11=energia1(0)
11841             call etotal_short(energia1)
11842             etot12=energia1(0)
11843           endif
11844 !- end split gradient
11845         c(j,i+nres)=ddx(j)-aincr
11846           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11847           call int_from_cart1(.false.)
11848           if (.not.split_ene) then
11849             call etotal(energia1)
11850             etot2=energia1(0)
11851           ggg(j+3)=(etot1-etot2)/(2*aincr)
11852           else
11853 !- split gradient
11854             call etotal_long(energia1)
11855             etot21=energia1(0)
11856           ggg(j+3)=(etot11-etot21)/(2*aincr)
11857             call etotal_short(energia1)
11858             etot22=energia1(0)
11859           ggg1(j+3)=(etot12-etot22)/(2*aincr)
11860 !- end split gradient
11861           endif
11862 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11863         c(j,i+nres)=ddx(j)
11864           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11865           dc_norm(j,i+nres)=dxnorm_safe(j)
11866           call int_from_cart1(.false.)
11867         enddo
11868       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11869          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11870         if (split_ene) then
11871           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11872          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11873          k=1,6)
11874          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11875          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11876          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11877         endif
11878       enddo
11879       return
11880       end subroutine check_ecartint
11881 #else
11882 !-----------------------------------------------------------------------------
11883       subroutine check_ecartint
11884 ! Check the gradient of the energy in Cartesian coordinates.
11885       use io_base, only: intout
11886 !      implicit real*8 (a-h,o-z)
11887 !      include 'DIMENSIONS'
11888 !      include 'COMMON.CONTROL'
11889 !      include 'COMMON.CHAIN'
11890 !      include 'COMMON.DERIV'
11891 !      include 'COMMON.IOUNITS'
11892 !      include 'COMMON.VAR'
11893 !      include 'COMMON.CONTACTS'
11894 !      include 'COMMON.MD'
11895 !      include 'COMMON.LOCAL'
11896 !      include 'COMMON.SPLITELE'
11897       use comm_srutu
11898 !el      integer :: icall
11899 !el      common /srutu/ icall
11900       real(kind=8),dimension(6) :: ggg,ggg1
11901       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11902       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11903       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
11904       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11905       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11906       real(kind=8),dimension(0:n_ene) :: energia,energia1
11907       integer :: uiparm(1)
11908       real(kind=8) :: urparm(1)
11909 !EL      external fdum
11910       integer :: i,j,k,nf
11911       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11912                    etot21,etot22
11913       r_cut=2.0d0
11914       rlambd=0.3d0
11915       icg=1
11916       nf=0
11917       nfl=0
11918       call intout
11919 !      call intcartderiv
11920 !      call checkintcartgrad
11921       call zerograd
11922       aincr=2.0D-5
11923       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
11924       nf=0
11925       icall=0
11926       call geom_to_var(nvar,x)
11927       if (.not.split_ene) then
11928         call etotal(energia)
11929         etot=energia(0)
11930 !el        call enerprint(energia)
11931         call flush(iout)
11932         write (iout,*) "enter cartgrad"
11933         call flush(iout)
11934         call cartgrad
11935         write (iout,*) "exit cartgrad"
11936         call flush(iout)
11937         icall =1
11938         do i=1,nres
11939           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11940         enddo
11941         do j=1,3
11942           grad_s(j,0)=gcart(j,0)
11943         enddo
11944         do i=1,nres
11945           do j=1,3
11946             grad_s(j,i)=gcart(j,i)
11947 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
11948             grad_s(j+3,i)=gxcart(j,i)
11949           enddo
11950         enddo
11951       else
11952 !- split gradient check
11953         call zerograd
11954         call etotal_long(energia)
11955 !el        call enerprint(energia)
11956         call flush(iout)
11957         write (iout,*) "enter cartgrad"
11958         call flush(iout)
11959         call cartgrad
11960         write (iout,*) "exit cartgrad"
11961         call flush(iout)
11962         icall =1
11963         write (iout,*) "longrange grad"
11964         do i=1,nres
11965           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11966           (gxcart(j,i),j=1,3)
11967         enddo
11968         do j=1,3
11969           grad_s(j,0)=gcart(j,0)
11970         enddo
11971         do i=1,nres
11972           do j=1,3
11973             grad_s(j,i)=gcart(j,i)
11974             grad_s(j+3,i)=gxcart(j,i)
11975           enddo
11976         enddo
11977         call zerograd
11978         call etotal_short(energia)
11979 !el        call enerprint(energia)
11980         call flush(iout)
11981         write (iout,*) "enter cartgrad"
11982         call flush(iout)
11983         call cartgrad
11984         write (iout,*) "exit cartgrad"
11985         call flush(iout)
11986         icall =1
11987         write (iout,*) "shortrange grad"
11988         do i=1,nres
11989           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11990           (gxcart(j,i),j=1,3)
11991         enddo
11992         do j=1,3
11993           grad_s1(j,0)=gcart(j,0)
11994         enddo
11995         do i=1,nres
11996           do j=1,3
11997             grad_s1(j,i)=gcart(j,i)
11998             grad_s1(j+3,i)=gxcart(j,i)
11999           enddo
12000         enddo
12001       endif
12002       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12003       do i=0,nres
12004         do j=1,3
12005         xx(j)=c(j,i+nres)
12006         ddc(j)=dc(j,i)
12007         ddx(j)=dc(j,i+nres)
12008           do k=1,3
12009             dcnorm_safe(k)=dc_norm(k,i)
12010             dxnorm_safe(k)=dc_norm(k,i+nres)
12011           enddo
12012         enddo
12013       do j=1,3
12014         dc(j,i)=ddc(j)+aincr
12015           call chainbuild_cart
12016 #ifdef MPI
12017 ! Broadcast the order to compute internal coordinates to the slaves.
12018 !          if (nfgtasks.gt.1)
12019 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12020 #endif
12021 !          call int_from_cart1(.false.)
12022           if (.not.split_ene) then
12023             call etotal(energia1)
12024             etot1=energia1(0)
12025 !            call enerprint(energia1)
12026           else
12027 !- split gradient
12028             call etotal_long(energia1)
12029             etot11=energia1(0)
12030             call etotal_short(energia1)
12031             etot12=energia1(0)
12032 !            write (iout,*) "etot11",etot11," etot12",etot12
12033           endif
12034 !- end split gradient
12035 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12036         dc(j,i)=ddc(j)-aincr
12037           call chainbuild_cart
12038 !          call int_from_cart1(.false.)
12039           if (.not.split_ene) then
12040             call etotal(energia1)
12041             etot2=energia1(0)
12042           ggg(j)=(etot1-etot2)/(2*aincr)
12043           else
12044 !- split gradient
12045             call etotal_long(energia1)
12046             etot21=energia1(0)
12047           ggg(j)=(etot11-etot21)/(2*aincr)
12048             call etotal_short(energia1)
12049             etot22=energia1(0)
12050           ggg1(j)=(etot12-etot22)/(2*aincr)
12051 !- end split gradient
12052 !            write (iout,*) "etot21",etot21," etot22",etot22
12053           endif
12054 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12055         dc(j,i)=ddc(j)
12056           call chainbuild_cart
12057         enddo
12058       do j=1,3
12059         dc(j,i+nres)=ddx(j)+aincr
12060           call chainbuild_cart
12061 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12062 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12063 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12064 !          write (iout,*) "dxnormnorm",dsqrt(
12065 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12066 !          write (iout,*) "dxnormnormsafe",dsqrt(
12067 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12068 !          write (iout,*)
12069           if (.not.split_ene) then
12070             call etotal(energia1)
12071             etot1=energia1(0)
12072           else
12073 !- split gradient
12074             call etotal_long(energia1)
12075             etot11=energia1(0)
12076             call etotal_short(energia1)
12077             etot12=energia1(0)
12078           endif
12079 !- end split gradient
12080 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12081         dc(j,i+nres)=ddx(j)-aincr
12082           call chainbuild_cart
12083 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12084 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12085 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12086 !          write (iout,*)
12087 !          write (iout,*) "dxnormnorm",dsqrt(
12088 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12089 !          write (iout,*) "dxnormnormsafe",dsqrt(
12090 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12091           if (.not.split_ene) then
12092             call etotal(energia1)
12093             etot2=energia1(0)
12094           ggg(j+3)=(etot1-etot2)/(2*aincr)
12095           else
12096 !- split gradient
12097             call etotal_long(energia1)
12098             etot21=energia1(0)
12099           ggg(j+3)=(etot11-etot21)/(2*aincr)
12100             call etotal_short(energia1)
12101             etot22=energia1(0)
12102           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12103 !- end split gradient
12104           endif
12105 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12106         dc(j,i+nres)=ddx(j)
12107           call chainbuild_cart
12108         enddo
12109       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12110          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12111         if (split_ene) then
12112           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12113          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12114          k=1,6)
12115          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12116          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12117          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12118         endif
12119       enddo
12120       return
12121       end subroutine check_ecartint
12122 #endif
12123 !-----------------------------------------------------------------------------
12124       subroutine check_eint
12125 ! Check the gradient of energy in internal coordinates.
12126 !      implicit real*8 (a-h,o-z)
12127 !      include 'DIMENSIONS'
12128 !      include 'COMMON.CHAIN'
12129 !      include 'COMMON.DERIV'
12130 !      include 'COMMON.IOUNITS'
12131 !      include 'COMMON.VAR'
12132 !      include 'COMMON.GEO'
12133       use comm_srutu
12134 !el      integer :: icall
12135 !el      common /srutu/ icall
12136       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12137       integer :: uiparm(1)
12138       real(kind=8) :: urparm(1)
12139       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12140       character(len=6) :: key
12141 !EL      external fdum
12142       integer :: i,ii,nf
12143       real(kind=8) :: xi,aincr,etot,etot1,etot2
12144       call zerograd
12145       aincr=1.0D-7
12146       print '(a)','Calling CHECK_INT.'
12147       nf=0
12148       nfl=0
12149       icg=1
12150       call geom_to_var(nvar,x)
12151       call var_to_geom(nvar,x)
12152       call chainbuild
12153       icall=1
12154 !      print *,'ICG=',ICG
12155       call etotal(energia)
12156       etot = energia(0)
12157 !el      call enerprint(energia)
12158 !      print *,'ICG=',ICG
12159 #ifdef MPL
12160       if (MyID.ne.BossID) then
12161         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12162         nf=x(nvar+1)
12163         nfl=x(nvar+2)
12164         icg=x(nvar+3)
12165       endif
12166 #endif
12167       nf=1
12168       nfl=3
12169 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12170       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12171 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12172       icall=1
12173       do i=1,nvar
12174         xi=x(i)
12175         x(i)=xi-0.5D0*aincr
12176         call var_to_geom(nvar,x)
12177         call chainbuild
12178         call etotal(energia1)
12179         etot1=energia1(0)
12180         x(i)=xi+0.5D0*aincr
12181         call var_to_geom(nvar,x)
12182         call chainbuild
12183         call etotal(energia2)
12184         etot2=energia2(0)
12185         gg(i)=(etot2-etot1)/aincr
12186         write (iout,*) i,etot1,etot2
12187         x(i)=xi
12188       enddo
12189       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12190           '     RelDiff*100% '
12191       do i=1,nvar
12192         if (i.le.nphi) then
12193           ii=i
12194           key = ' phi'
12195         else if (i.le.nphi+ntheta) then
12196           ii=i-nphi
12197           key=' theta'
12198         else if (i.le.nphi+ntheta+nside) then
12199            ii=i-(nphi+ntheta)
12200            key=' alpha'
12201         else
12202            ii=i-(nphi+ntheta+nside)
12203            key=' omega'
12204         endif
12205         write (iout,'(i3,a,i3,3(1pd16.6))') &
12206        i,key,ii,gg(i),gana(i),&
12207        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12208       enddo
12209       return
12210       end subroutine check_eint
12211 !-----------------------------------------------------------------------------
12212 ! econstr_local.F
12213 !-----------------------------------------------------------------------------
12214       subroutine Econstr_back
12215 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12216 !      implicit real*8 (a-h,o-z)
12217 !      include 'DIMENSIONS'
12218 !      include 'COMMON.CONTROL'
12219 !      include 'COMMON.VAR'
12220 !      include 'COMMON.MD'
12221       use MD_data
12222 !#ifndef LANG0
12223 !      include 'COMMON.LANGEVIN'
12224 !#else
12225 !      include 'COMMON.LANGEVIN.lang0'
12226 !#endif
12227 !      include 'COMMON.CHAIN'
12228 !      include 'COMMON.DERIV'
12229 !      include 'COMMON.GEO'
12230 !      include 'COMMON.LOCAL'
12231 !      include 'COMMON.INTERACT'
12232 !      include 'COMMON.IOUNITS'
12233 !      include 'COMMON.NAMES'
12234 !      include 'COMMON.TIME1'
12235       integer :: i,j,ii,k
12236       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12237
12238       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12239       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12240       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12241
12242       Uconst_back=0.0d0
12243       do i=1,nres
12244         dutheta(i)=0.0d0
12245         dugamma(i)=0.0d0
12246         do j=1,3
12247           duscdiff(j,i)=0.0d0
12248           duscdiffx(j,i)=0.0d0
12249         enddo
12250       enddo
12251       do i=1,nfrag_back
12252         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12253 !
12254 ! Deviations from theta angles
12255 !
12256         utheta_i=0.0d0
12257         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12258           dtheta_i=theta(j)-thetaref(j)
12259           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12260           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12261         enddo
12262         utheta(i)=utheta_i/(ii-1)
12263 !
12264 ! Deviations from gamma angles
12265 !
12266         ugamma_i=0.0d0
12267         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12268           dgamma_i=pinorm(phi(j)-phiref(j))
12269 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12270           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12271           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12272 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12273         enddo
12274         ugamma(i)=ugamma_i/(ii-2)
12275 !
12276 ! Deviations from local SC geometry
12277 !
12278         uscdiff(i)=0.0d0
12279         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12280           dxx=xxtab(j)-xxref(j)
12281           dyy=yytab(j)-yyref(j)
12282           dzz=zztab(j)-zzref(j)
12283           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12284           do k=1,3
12285             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12286              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12287              (ii-1)
12288             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12289              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12290              (ii-1)
12291             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12292            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12293             /(ii-1)
12294           enddo
12295 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12296 !     &      xxref(j),yyref(j),zzref(j)
12297         enddo
12298         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12299 !        write (iout,*) i," uscdiff",uscdiff(i)
12300 !
12301 ! Put together deviations from local geometry
12302 !
12303         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12304           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12305 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12306 !     &   " uconst_back",uconst_back
12307         utheta(i)=dsqrt(utheta(i))
12308         ugamma(i)=dsqrt(ugamma(i))
12309         uscdiff(i)=dsqrt(uscdiff(i))
12310       enddo
12311       return
12312       end subroutine Econstr_back
12313 !-----------------------------------------------------------------------------
12314 ! energy_p_new-sep_barrier.F
12315 !-----------------------------------------------------------------------------
12316       real(kind=8) function sscale(r)
12317 !      include "COMMON.SPLITELE"
12318       real(kind=8) :: r,gamm
12319       if(r.lt.r_cut-rlamb) then
12320         sscale=1.0d0
12321       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12322         gamm=(r-(r_cut-rlamb))/rlamb
12323         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12324       else
12325         sscale=0d0
12326       endif
12327       return
12328       end function sscale
12329       real(kind=8) function sscale_grad(r)
12330 !      include "COMMON.SPLITELE"
12331       real(kind=8) :: r,gamm
12332       if(r.lt.r_cut-rlamb) then
12333         sscale_grad=0.0d0
12334       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12335         gamm=(r-(r_cut-rlamb))/rlamb
12336         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12337       else
12338         sscale_grad=0d0
12339       endif
12340       return
12341       end function sscale_grad
12342
12343 !!!!!!!!!! PBCSCALE
12344       real(kind=8) function sscale_ele(r)
12345 !      include "COMMON.SPLITELE"
12346       real(kind=8) :: r,gamm
12347       if(r.lt.r_cut_ele-rlamb_ele) then
12348         sscale_ele=1.0d0
12349       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12350         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12351         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12352       else
12353         sscale_ele=0d0
12354       endif
12355       return
12356       end function sscale_ele
12357
12358       real(kind=8)  function sscagrad_ele(r)
12359       real(kind=8) :: r,gamm
12360 !      include "COMMON.SPLITELE"
12361       if(r.lt.r_cut_ele-rlamb_ele) then
12362         sscagrad_ele=0.0d0
12363       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12364         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12365         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12366       else
12367         sscagrad_ele=0.0d0
12368       endif
12369       return
12370       end function sscagrad_ele
12371       real(kind=8) function sscalelip(r)
12372       real(kind=8) r,gamm
12373         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12374       return
12375       end function sscalelip
12376 !C-----------------------------------------------------------------------
12377       real(kind=8) function sscagradlip(r)
12378       real(kind=8) r,gamm
12379         sscagradlip=r*(6.0d0*r-6.0d0)
12380       return
12381       end function sscagradlip
12382
12383 !!!!!!!!!!!!!!!
12384 !-----------------------------------------------------------------------------
12385       subroutine elj_long(evdw)
12386 !
12387 ! This subroutine calculates the interaction energy of nonbonded side chains
12388 ! assuming the LJ potential of interaction.
12389 !
12390 !      implicit real*8 (a-h,o-z)
12391 !      include 'DIMENSIONS'
12392 !      include 'COMMON.GEO'
12393 !      include 'COMMON.VAR'
12394 !      include 'COMMON.LOCAL'
12395 !      include 'COMMON.CHAIN'
12396 !      include 'COMMON.DERIV'
12397 !      include 'COMMON.INTERACT'
12398 !      include 'COMMON.TORSION'
12399 !      include 'COMMON.SBRIDGE'
12400 !      include 'COMMON.NAMES'
12401 !      include 'COMMON.IOUNITS'
12402 !      include 'COMMON.CONTACTS'
12403       real(kind=8),parameter :: accur=1.0d-10
12404       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12405 !el local variables
12406       integer :: i,iint,j,k,itypi,itypi1,itypj
12407       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12408       real(kind=8) :: e1,e2,evdwij,evdw
12409 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12410       evdw=0.0D0
12411       do i=iatsc_s,iatsc_e
12412         itypi=itype(i,1)
12413         if (itypi.eq.ntyp1) cycle
12414         itypi1=itype(i+1,1)
12415         xi=c(1,nres+i)
12416         yi=c(2,nres+i)
12417         zi=c(3,nres+i)
12418 !
12419 ! Calculate SC interaction energy.
12420 !
12421         do iint=1,nint_gr(i)
12422 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12423 !d   &                  'iend=',iend(i,iint)
12424           do j=istart(i,iint),iend(i,iint)
12425             itypj=itype(j,1)
12426             if (itypj.eq.ntyp1) cycle
12427             xj=c(1,nres+j)-xi
12428             yj=c(2,nres+j)-yi
12429             zj=c(3,nres+j)-zi
12430             rij=xj*xj+yj*yj+zj*zj
12431             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12432             if (sss.lt.1.0d0) then
12433               rrij=1.0D0/rij
12434               eps0ij=eps(itypi,itypj)
12435               fac=rrij**expon2
12436               e1=fac*fac*aa_aq(itypi,itypj)
12437               e2=fac*bb_aq(itypi,itypj)
12438               evdwij=e1+e2
12439               evdw=evdw+(1.0d0-sss)*evdwij
12440 !
12441 ! Calculate the components of the gradient in DC and X
12442 !
12443               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12444               gg(1)=xj*fac
12445               gg(2)=yj*fac
12446               gg(3)=zj*fac
12447               do k=1,3
12448                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12449                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12450                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12451                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12452               enddo
12453             endif
12454           enddo      ! j
12455         enddo        ! iint
12456       enddo          ! i
12457       do i=1,nct
12458         do j=1,3
12459           gvdwc(j,i)=expon*gvdwc(j,i)
12460           gvdwx(j,i)=expon*gvdwx(j,i)
12461         enddo
12462       enddo
12463 !******************************************************************************
12464 !
12465 !                              N O T E !!!
12466 !
12467 ! To save time, the factor of EXPON has been extracted from ALL components
12468 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12469 ! use!
12470 !
12471 !******************************************************************************
12472       return
12473       end subroutine elj_long
12474 !-----------------------------------------------------------------------------
12475       subroutine elj_short(evdw)
12476 !
12477 ! This subroutine calculates the interaction energy of nonbonded side chains
12478 ! assuming the LJ potential of interaction.
12479 !
12480 !      implicit real*8 (a-h,o-z)
12481 !      include 'DIMENSIONS'
12482 !      include 'COMMON.GEO'
12483 !      include 'COMMON.VAR'
12484 !      include 'COMMON.LOCAL'
12485 !      include 'COMMON.CHAIN'
12486 !      include 'COMMON.DERIV'
12487 !      include 'COMMON.INTERACT'
12488 !      include 'COMMON.TORSION'
12489 !      include 'COMMON.SBRIDGE'
12490 !      include 'COMMON.NAMES'
12491 !      include 'COMMON.IOUNITS'
12492 !      include 'COMMON.CONTACTS'
12493       real(kind=8),parameter :: accur=1.0d-10
12494       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12495 !el local variables
12496       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12497       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12498       real(kind=8) :: e1,e2,evdwij,evdw
12499 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12500       evdw=0.0D0
12501       do i=iatsc_s,iatsc_e
12502         itypi=itype(i,1)
12503         if (itypi.eq.ntyp1) cycle
12504         itypi1=itype(i+1,1)
12505         xi=c(1,nres+i)
12506         yi=c(2,nres+i)
12507         zi=c(3,nres+i)
12508 ! Change 12/1/95
12509         num_conti=0
12510 !
12511 ! Calculate SC interaction energy.
12512 !
12513         do iint=1,nint_gr(i)
12514 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12515 !d   &                  'iend=',iend(i,iint)
12516           do j=istart(i,iint),iend(i,iint)
12517             itypj=itype(j,1)
12518             if (itypj.eq.ntyp1) cycle
12519             xj=c(1,nres+j)-xi
12520             yj=c(2,nres+j)-yi
12521             zj=c(3,nres+j)-zi
12522 ! Change 12/1/95 to calculate four-body interactions
12523             rij=xj*xj+yj*yj+zj*zj
12524             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12525             if (sss.gt.0.0d0) then
12526               rrij=1.0D0/rij
12527               eps0ij=eps(itypi,itypj)
12528               fac=rrij**expon2
12529               e1=fac*fac*aa_aq(itypi,itypj)
12530               e2=fac*bb_aq(itypi,itypj)
12531               evdwij=e1+e2
12532               evdw=evdw+sss*evdwij
12533 !
12534 ! Calculate the components of the gradient in DC and X
12535 !
12536               fac=-rrij*(e1+evdwij)*sss
12537               gg(1)=xj*fac
12538               gg(2)=yj*fac
12539               gg(3)=zj*fac
12540               do k=1,3
12541                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12542                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12543                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12544                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12545               enddo
12546             endif
12547           enddo      ! j
12548         enddo        ! iint
12549       enddo          ! i
12550       do i=1,nct
12551         do j=1,3
12552           gvdwc(j,i)=expon*gvdwc(j,i)
12553           gvdwx(j,i)=expon*gvdwx(j,i)
12554         enddo
12555       enddo
12556 !******************************************************************************
12557 !
12558 !                              N O T E !!!
12559 !
12560 ! To save time, the factor of EXPON has been extracted from ALL components
12561 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12562 ! use!
12563 !
12564 !******************************************************************************
12565       return
12566       end subroutine elj_short
12567 !-----------------------------------------------------------------------------
12568       subroutine eljk_long(evdw)
12569 !
12570 ! This subroutine calculates the interaction energy of nonbonded side chains
12571 ! assuming the LJK potential of interaction.
12572 !
12573 !      implicit real*8 (a-h,o-z)
12574 !      include 'DIMENSIONS'
12575 !      include 'COMMON.GEO'
12576 !      include 'COMMON.VAR'
12577 !      include 'COMMON.LOCAL'
12578 !      include 'COMMON.CHAIN'
12579 !      include 'COMMON.DERIV'
12580 !      include 'COMMON.INTERACT'
12581 !      include 'COMMON.IOUNITS'
12582 !      include 'COMMON.NAMES'
12583       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12584       logical :: scheck
12585 !el local variables
12586       integer :: i,iint,j,k,itypi,itypi1,itypj
12587       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12588                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12589 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12590       evdw=0.0D0
12591       do i=iatsc_s,iatsc_e
12592         itypi=itype(i,1)
12593         if (itypi.eq.ntyp1) cycle
12594         itypi1=itype(i+1,1)
12595         xi=c(1,nres+i)
12596         yi=c(2,nres+i)
12597         zi=c(3,nres+i)
12598 !
12599 ! Calculate SC interaction energy.
12600 !
12601         do iint=1,nint_gr(i)
12602           do j=istart(i,iint),iend(i,iint)
12603             itypj=itype(j,1)
12604             if (itypj.eq.ntyp1) cycle
12605             xj=c(1,nres+j)-xi
12606             yj=c(2,nres+j)-yi
12607             zj=c(3,nres+j)-zi
12608             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12609             fac_augm=rrij**expon
12610             e_augm=augm(itypi,itypj)*fac_augm
12611             r_inv_ij=dsqrt(rrij)
12612             rij=1.0D0/r_inv_ij
12613             sss=sscale(rij/sigma(itypi,itypj))
12614             if (sss.lt.1.0d0) then
12615               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12616               fac=r_shift_inv**expon
12617               e1=fac*fac*aa_aq(itypi,itypj)
12618               e2=fac*bb_aq(itypi,itypj)
12619               evdwij=e_augm+e1+e2
12620 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12621 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12622 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12623 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12624 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12625 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12626 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12627               evdw=evdw+(1.0d0-sss)*evdwij
12628 !
12629 ! Calculate the components of the gradient in DC and X
12630 !
12631               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12632               fac=fac*(1.0d0-sss)
12633               gg(1)=xj*fac
12634               gg(2)=yj*fac
12635               gg(3)=zj*fac
12636               do k=1,3
12637                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12638                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12639                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12640                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12641               enddo
12642             endif
12643           enddo      ! j
12644         enddo        ! iint
12645       enddo          ! i
12646       do i=1,nct
12647         do j=1,3
12648           gvdwc(j,i)=expon*gvdwc(j,i)
12649           gvdwx(j,i)=expon*gvdwx(j,i)
12650         enddo
12651       enddo
12652       return
12653       end subroutine eljk_long
12654 !-----------------------------------------------------------------------------
12655       subroutine eljk_short(evdw)
12656 !
12657 ! This subroutine calculates the interaction energy of nonbonded side chains
12658 ! assuming the LJK potential of interaction.
12659 !
12660 !      implicit real*8 (a-h,o-z)
12661 !      include 'DIMENSIONS'
12662 !      include 'COMMON.GEO'
12663 !      include 'COMMON.VAR'
12664 !      include 'COMMON.LOCAL'
12665 !      include 'COMMON.CHAIN'
12666 !      include 'COMMON.DERIV'
12667 !      include 'COMMON.INTERACT'
12668 !      include 'COMMON.IOUNITS'
12669 !      include 'COMMON.NAMES'
12670       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12671       logical :: scheck
12672 !el local variables
12673       integer :: i,iint,j,k,itypi,itypi1,itypj
12674       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12675                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12676 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12677       evdw=0.0D0
12678       do i=iatsc_s,iatsc_e
12679         itypi=itype(i,1)
12680         if (itypi.eq.ntyp1) cycle
12681         itypi1=itype(i+1,1)
12682         xi=c(1,nres+i)
12683         yi=c(2,nres+i)
12684         zi=c(3,nres+i)
12685 !
12686 ! Calculate SC interaction energy.
12687 !
12688         do iint=1,nint_gr(i)
12689           do j=istart(i,iint),iend(i,iint)
12690             itypj=itype(j,1)
12691             if (itypj.eq.ntyp1) cycle
12692             xj=c(1,nres+j)-xi
12693             yj=c(2,nres+j)-yi
12694             zj=c(3,nres+j)-zi
12695             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12696             fac_augm=rrij**expon
12697             e_augm=augm(itypi,itypj)*fac_augm
12698             r_inv_ij=dsqrt(rrij)
12699             rij=1.0D0/r_inv_ij
12700             sss=sscale(rij/sigma(itypi,itypj))
12701             if (sss.gt.0.0d0) then
12702               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12703               fac=r_shift_inv**expon
12704               e1=fac*fac*aa_aq(itypi,itypj)
12705               e2=fac*bb_aq(itypi,itypj)
12706               evdwij=e_augm+e1+e2
12707 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12708 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12709 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12710 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12711 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12712 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12713 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12714               evdw=evdw+sss*evdwij
12715 !
12716 ! Calculate the components of the gradient in DC and X
12717 !
12718               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12719               fac=fac*sss
12720               gg(1)=xj*fac
12721               gg(2)=yj*fac
12722               gg(3)=zj*fac
12723               do k=1,3
12724                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12725                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12726                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12727                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12728               enddo
12729             endif
12730           enddo      ! j
12731         enddo        ! iint
12732       enddo          ! i
12733       do i=1,nct
12734         do j=1,3
12735           gvdwc(j,i)=expon*gvdwc(j,i)
12736           gvdwx(j,i)=expon*gvdwx(j,i)
12737         enddo
12738       enddo
12739       return
12740       end subroutine eljk_short
12741 !-----------------------------------------------------------------------------
12742       subroutine ebp_long(evdw)
12743 !
12744 ! This subroutine calculates the interaction energy of nonbonded side chains
12745 ! assuming the Berne-Pechukas potential of interaction.
12746 !
12747       use calc_data
12748 !      implicit real*8 (a-h,o-z)
12749 !      include 'DIMENSIONS'
12750 !      include 'COMMON.GEO'
12751 !      include 'COMMON.VAR'
12752 !      include 'COMMON.LOCAL'
12753 !      include 'COMMON.CHAIN'
12754 !      include 'COMMON.DERIV'
12755 !      include 'COMMON.NAMES'
12756 !      include 'COMMON.INTERACT'
12757 !      include 'COMMON.IOUNITS'
12758 !      include 'COMMON.CALC'
12759       use comm_srutu
12760 !el      integer :: icall
12761 !el      common /srutu/ icall
12762 !     double precision rrsave(maxdim)
12763       logical :: lprn
12764 !el local variables
12765       integer :: iint,itypi,itypi1,itypj
12766       real(kind=8) :: rrij,xi,yi,zi,fac
12767       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12768       evdw=0.0D0
12769 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12770       evdw=0.0D0
12771 !     if (icall.eq.0) then
12772 !       lprn=.true.
12773 !     else
12774         lprn=.false.
12775 !     endif
12776 !el      ind=0
12777       do i=iatsc_s,iatsc_e
12778         itypi=itype(i,1)
12779         if (itypi.eq.ntyp1) cycle
12780         itypi1=itype(i+1,1)
12781         xi=c(1,nres+i)
12782         yi=c(2,nres+i)
12783         zi=c(3,nres+i)
12784         dxi=dc_norm(1,nres+i)
12785         dyi=dc_norm(2,nres+i)
12786         dzi=dc_norm(3,nres+i)
12787 !        dsci_inv=dsc_inv(itypi)
12788         dsci_inv=vbld_inv(i+nres)
12789 !
12790 ! Calculate SC interaction energy.
12791 !
12792         do iint=1,nint_gr(i)
12793           do j=istart(i,iint),iend(i,iint)
12794 !el            ind=ind+1
12795             itypj=itype(j,1)
12796             if (itypj.eq.ntyp1) cycle
12797 !            dscj_inv=dsc_inv(itypj)
12798             dscj_inv=vbld_inv(j+nres)
12799             chi1=chi(itypi,itypj)
12800             chi2=chi(itypj,itypi)
12801             chi12=chi1*chi2
12802             chip1=chip(itypi)
12803             chip2=chip(itypj)
12804             chip12=chip1*chip2
12805             alf1=alp(itypi)
12806             alf2=alp(itypj)
12807             alf12=0.5D0*(alf1+alf2)
12808             xj=c(1,nres+j)-xi
12809             yj=c(2,nres+j)-yi
12810             zj=c(3,nres+j)-zi
12811             dxj=dc_norm(1,nres+j)
12812             dyj=dc_norm(2,nres+j)
12813             dzj=dc_norm(3,nres+j)
12814             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12815             rij=dsqrt(rrij)
12816             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12817
12818             if (sss.lt.1.0d0) then
12819
12820 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12821               call sc_angular
12822 ! Calculate whole angle-dependent part of epsilon and contributions
12823 ! to its derivatives
12824               fac=(rrij*sigsq)**expon2
12825               e1=fac*fac*aa_aq(itypi,itypj)
12826               e2=fac*bb_aq(itypi,itypj)
12827               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12828               eps2der=evdwij*eps3rt
12829               eps3der=evdwij*eps2rt
12830               evdwij=evdwij*eps2rt*eps3rt
12831               evdw=evdw+evdwij*(1.0d0-sss)
12832               if (lprn) then
12833               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12834               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12835 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12836 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12837 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12838 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12839 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12840 !d     &          evdwij
12841               endif
12842 ! Calculate gradient components.
12843               e1=e1*eps1*eps2rt**2*eps3rt**2
12844               fac=-expon*(e1+evdwij)
12845               sigder=fac/sigsq
12846               fac=rrij*fac
12847 ! Calculate radial part of the gradient
12848               gg(1)=xj*fac
12849               gg(2)=yj*fac
12850               gg(3)=zj*fac
12851 ! Calculate the angular part of the gradient and sum add the contributions
12852 ! to the appropriate components of the Cartesian gradient.
12853               call sc_grad_scale(1.0d0-sss)
12854             endif
12855           enddo      ! j
12856         enddo        ! iint
12857       enddo          ! i
12858 !     stop
12859       return
12860       end subroutine ebp_long
12861 !-----------------------------------------------------------------------------
12862       subroutine ebp_short(evdw)
12863 !
12864 ! This subroutine calculates the interaction energy of nonbonded side chains
12865 ! assuming the Berne-Pechukas potential of interaction.
12866 !
12867       use calc_data
12868 !      implicit real*8 (a-h,o-z)
12869 !      include 'DIMENSIONS'
12870 !      include 'COMMON.GEO'
12871 !      include 'COMMON.VAR'
12872 !      include 'COMMON.LOCAL'
12873 !      include 'COMMON.CHAIN'
12874 !      include 'COMMON.DERIV'
12875 !      include 'COMMON.NAMES'
12876 !      include 'COMMON.INTERACT'
12877 !      include 'COMMON.IOUNITS'
12878 !      include 'COMMON.CALC'
12879       use comm_srutu
12880 !el      integer :: icall
12881 !el      common /srutu/ icall
12882 !     double precision rrsave(maxdim)
12883       logical :: lprn
12884 !el local variables
12885       integer :: iint,itypi,itypi1,itypj
12886       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12887       real(kind=8) :: sss,e1,e2,evdw
12888       evdw=0.0D0
12889 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12890       evdw=0.0D0
12891 !     if (icall.eq.0) then
12892 !       lprn=.true.
12893 !     else
12894         lprn=.false.
12895 !     endif
12896 !el      ind=0
12897       do i=iatsc_s,iatsc_e
12898         itypi=itype(i,1)
12899         if (itypi.eq.ntyp1) cycle
12900         itypi1=itype(i+1,1)
12901         xi=c(1,nres+i)
12902         yi=c(2,nres+i)
12903         zi=c(3,nres+i)
12904         dxi=dc_norm(1,nres+i)
12905         dyi=dc_norm(2,nres+i)
12906         dzi=dc_norm(3,nres+i)
12907 !        dsci_inv=dsc_inv(itypi)
12908         dsci_inv=vbld_inv(i+nres)
12909 !
12910 ! Calculate SC interaction energy.
12911 !
12912         do iint=1,nint_gr(i)
12913           do j=istart(i,iint),iend(i,iint)
12914 !el            ind=ind+1
12915             itypj=itype(j,1)
12916             if (itypj.eq.ntyp1) cycle
12917 !            dscj_inv=dsc_inv(itypj)
12918             dscj_inv=vbld_inv(j+nres)
12919             chi1=chi(itypi,itypj)
12920             chi2=chi(itypj,itypi)
12921             chi12=chi1*chi2
12922             chip1=chip(itypi)
12923             chip2=chip(itypj)
12924             chip12=chip1*chip2
12925             alf1=alp(itypi)
12926             alf2=alp(itypj)
12927             alf12=0.5D0*(alf1+alf2)
12928             xj=c(1,nres+j)-xi
12929             yj=c(2,nres+j)-yi
12930             zj=c(3,nres+j)-zi
12931             dxj=dc_norm(1,nres+j)
12932             dyj=dc_norm(2,nres+j)
12933             dzj=dc_norm(3,nres+j)
12934             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12935             rij=dsqrt(rrij)
12936             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12937
12938             if (sss.gt.0.0d0) then
12939
12940 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12941               call sc_angular
12942 ! Calculate whole angle-dependent part of epsilon and contributions
12943 ! to its derivatives
12944               fac=(rrij*sigsq)**expon2
12945               e1=fac*fac*aa_aq(itypi,itypj)
12946               e2=fac*bb_aq(itypi,itypj)
12947               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12948               eps2der=evdwij*eps3rt
12949               eps3der=evdwij*eps2rt
12950               evdwij=evdwij*eps2rt*eps3rt
12951               evdw=evdw+evdwij*sss
12952               if (lprn) then
12953               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12954               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12955 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12956 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12957 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12958 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12959 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12960 !d     &          evdwij
12961               endif
12962 ! Calculate gradient components.
12963               e1=e1*eps1*eps2rt**2*eps3rt**2
12964               fac=-expon*(e1+evdwij)
12965               sigder=fac/sigsq
12966               fac=rrij*fac
12967 ! Calculate radial part of the gradient
12968               gg(1)=xj*fac
12969               gg(2)=yj*fac
12970               gg(3)=zj*fac
12971 ! Calculate the angular part of the gradient and sum add the contributions
12972 ! to the appropriate components of the Cartesian gradient.
12973               call sc_grad_scale(sss)
12974             endif
12975           enddo      ! j
12976         enddo        ! iint
12977       enddo          ! i
12978 !     stop
12979       return
12980       end subroutine ebp_short
12981 !-----------------------------------------------------------------------------
12982       subroutine egb_long(evdw)
12983 !
12984 ! This subroutine calculates the interaction energy of nonbonded side chains
12985 ! assuming the Gay-Berne potential of interaction.
12986 !
12987       use calc_data
12988 !      implicit real*8 (a-h,o-z)
12989 !      include 'DIMENSIONS'
12990 !      include 'COMMON.GEO'
12991 !      include 'COMMON.VAR'
12992 !      include 'COMMON.LOCAL'
12993 !      include 'COMMON.CHAIN'
12994 !      include 'COMMON.DERIV'
12995 !      include 'COMMON.NAMES'
12996 !      include 'COMMON.INTERACT'
12997 !      include 'COMMON.IOUNITS'
12998 !      include 'COMMON.CALC'
12999 !      include 'COMMON.CONTROL'
13000       logical :: lprn
13001 !el local variables
13002       integer :: iint,itypi,itypi1,itypj,subchap
13003       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13004       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13005       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13006                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13007                     ssgradlipi,ssgradlipj
13008
13009
13010       evdw=0.0D0
13011 !cccc      energy_dec=.false.
13012 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13013       evdw=0.0D0
13014       lprn=.false.
13015 !     if (icall.eq.0) lprn=.false.
13016 !el      ind=0
13017       do i=iatsc_s,iatsc_e
13018         itypi=itype(i,1)
13019         if (itypi.eq.ntyp1) cycle
13020         itypi1=itype(i+1,1)
13021         xi=c(1,nres+i)
13022         yi=c(2,nres+i)
13023         zi=c(3,nres+i)
13024           xi=mod(xi,boxxsize)
13025           if (xi.lt.0) xi=xi+boxxsize
13026           yi=mod(yi,boxysize)
13027           if (yi.lt.0) yi=yi+boxysize
13028           zi=mod(zi,boxzsize)
13029           if (zi.lt.0) zi=zi+boxzsize
13030        if ((zi.gt.bordlipbot)    &
13031         .and.(zi.lt.bordliptop)) then
13032 !C the energy transfer exist
13033         if (zi.lt.buflipbot) then
13034 !C what fraction I am in
13035          fracinbuf=1.0d0-    &
13036              ((zi-bordlipbot)/lipbufthick)
13037 !C lipbufthick is thickenes of lipid buffore
13038          sslipi=sscalelip(fracinbuf)
13039          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13040         elseif (zi.gt.bufliptop) then
13041          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13042          sslipi=sscalelip(fracinbuf)
13043          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13044         else
13045          sslipi=1.0d0
13046          ssgradlipi=0.0
13047         endif
13048        else
13049          sslipi=0.0d0
13050          ssgradlipi=0.0
13051        endif
13052
13053         dxi=dc_norm(1,nres+i)
13054         dyi=dc_norm(2,nres+i)
13055         dzi=dc_norm(3,nres+i)
13056 !        dsci_inv=dsc_inv(itypi)
13057         dsci_inv=vbld_inv(i+nres)
13058 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13059 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13060 !
13061 ! Calculate SC interaction energy.
13062 !
13063         do iint=1,nint_gr(i)
13064           do j=istart(i,iint),iend(i,iint)
13065             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13066 !              call dyn_ssbond_ene(i,j,evdwij)
13067 !              evdw=evdw+evdwij
13068 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13069 !                              'evdw',i,j,evdwij,' ss'
13070 !              if (energy_dec) write (iout,*) &
13071 !                              'evdw',i,j,evdwij,' ss'
13072 !             do k=j+1,iend(i,iint)
13073 !C search over all next residues
13074 !              if (dyn_ss_mask(k)) then
13075 !C check if they are cysteins
13076 !C              write(iout,*) 'k=',k
13077
13078 !c              write(iout,*) "PRZED TRI", evdwij
13079 !               evdwij_przed_tri=evdwij
13080 !              call triple_ssbond_ene(i,j,k,evdwij)
13081 !c               if(evdwij_przed_tri.ne.evdwij) then
13082 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13083 !c               endif
13084
13085 !c              write(iout,*) "PO TRI", evdwij
13086 !C call the energy function that removes the artifical triple disulfide
13087 !C bond the soubroutine is located in ssMD.F
13088 !              evdw=evdw+evdwij
13089               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13090                             'evdw',i,j,evdwij,'tss'
13091 !              endif!dyn_ss_mask(k)
13092 !             enddo! k
13093
13094             ELSE
13095 !el            ind=ind+1
13096             itypj=itype(j,1)
13097             if (itypj.eq.ntyp1) cycle
13098 !            dscj_inv=dsc_inv(itypj)
13099             dscj_inv=vbld_inv(j+nres)
13100 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13101 !     &       1.0d0/vbld(j+nres)
13102 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13103             sig0ij=sigma(itypi,itypj)
13104             chi1=chi(itypi,itypj)
13105             chi2=chi(itypj,itypi)
13106             chi12=chi1*chi2
13107             chip1=chip(itypi)
13108             chip2=chip(itypj)
13109             chip12=chip1*chip2
13110             alf1=alp(itypi)
13111             alf2=alp(itypj)
13112             alf12=0.5D0*(alf1+alf2)
13113             xj=c(1,nres+j)
13114             yj=c(2,nres+j)
13115             zj=c(3,nres+j)
13116 ! Searching for nearest neighbour
13117           xj=mod(xj,boxxsize)
13118           if (xj.lt.0) xj=xj+boxxsize
13119           yj=mod(yj,boxysize)
13120           if (yj.lt.0) yj=yj+boxysize
13121           zj=mod(zj,boxzsize)
13122           if (zj.lt.0) zj=zj+boxzsize
13123        if ((zj.gt.bordlipbot)   &
13124       .and.(zj.lt.bordliptop)) then
13125 !C the energy transfer exist
13126         if (zj.lt.buflipbot) then
13127 !C what fraction I am in
13128          fracinbuf=1.0d0-  &
13129              ((zj-bordlipbot)/lipbufthick)
13130 !C lipbufthick is thickenes of lipid buffore
13131          sslipj=sscalelip(fracinbuf)
13132          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13133         elseif (zj.gt.bufliptop) then
13134          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13135          sslipj=sscalelip(fracinbuf)
13136          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13137         else
13138          sslipj=1.0d0
13139          ssgradlipj=0.0
13140         endif
13141        else
13142          sslipj=0.0d0
13143          ssgradlipj=0.0
13144        endif
13145       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13146        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13147       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13148        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13149
13150           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13151           xj_safe=xj
13152           yj_safe=yj
13153           zj_safe=zj
13154           subchap=0
13155           do xshift=-1,1
13156           do yshift=-1,1
13157           do zshift=-1,1
13158           xj=xj_safe+xshift*boxxsize
13159           yj=yj_safe+yshift*boxysize
13160           zj=zj_safe+zshift*boxzsize
13161           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13162           if(dist_temp.lt.dist_init) then
13163             dist_init=dist_temp
13164             xj_temp=xj
13165             yj_temp=yj
13166             zj_temp=zj
13167             subchap=1
13168           endif
13169           enddo
13170           enddo
13171           enddo
13172           if (subchap.eq.1) then
13173           xj=xj_temp-xi
13174           yj=yj_temp-yi
13175           zj=zj_temp-zi
13176           else
13177           xj=xj_safe-xi
13178           yj=yj_safe-yi
13179           zj=zj_safe-zi
13180           endif
13181
13182             dxj=dc_norm(1,nres+j)
13183             dyj=dc_norm(2,nres+j)
13184             dzj=dc_norm(3,nres+j)
13185             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13186             rij=dsqrt(rrij)
13187             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13188             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13189             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13190             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13191             if (sss_ele_cut.le.0.0) cycle
13192             if (sss.lt.1.0d0) then
13193
13194 ! Calculate angle-dependent terms of energy and contributions to their
13195 ! derivatives.
13196               call sc_angular
13197               sigsq=1.0D0/sigsq
13198               sig=sig0ij*dsqrt(sigsq)
13199               rij_shift=1.0D0/rij-sig+sig0ij
13200 ! for diagnostics; uncomment
13201 !              rij_shift=1.2*sig0ij
13202 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13203               if (rij_shift.le.0.0D0) then
13204                 evdw=1.0D20
13205 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13206 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13207 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13208                 return
13209               endif
13210               sigder=-sig*sigsq
13211 !---------------------------------------------------------------
13212               rij_shift=1.0D0/rij_shift
13213               fac=rij_shift**expon
13214               e1=fac*fac*aa
13215               e2=fac*bb
13216               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13217               eps2der=evdwij*eps3rt
13218               eps3der=evdwij*eps2rt
13219 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13220 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13221               evdwij=evdwij*eps2rt*eps3rt
13222               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13223               if (lprn) then
13224               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13225               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13226               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13227                 restyp(itypi,1),i,restyp(itypj,1),j,&
13228                 epsi,sigm,chi1,chi2,chip1,chip2,&
13229                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13230                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13231                 evdwij
13232               endif
13233
13234               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13235                               'evdw',i,j,evdwij
13236 !              if (energy_dec) write (iout,*) &
13237 !                              'evdw',i,j,evdwij,"egb_long"
13238
13239 ! Calculate gradient components.
13240               e1=e1*eps1*eps2rt**2*eps3rt**2
13241               fac=-expon*(e1+evdwij)*rij_shift
13242               sigder=fac*sigder
13243               fac=rij*fac
13244               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13245             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13246             /sigmaii(itypi,itypj))
13247 !              fac=0.0d0
13248 ! Calculate the radial part of the gradient
13249               gg(1)=xj*fac
13250               gg(2)=yj*fac
13251               gg(3)=zj*fac
13252 ! Calculate angular part of the gradient.
13253               call sc_grad_scale(1.0d0-sss)
13254             ENDIF    !mask_dyn_ss
13255             endif
13256           enddo      ! j
13257         enddo        ! iint
13258       enddo          ! i
13259 !      write (iout,*) "Number of loop steps in EGB:",ind
13260 !ccc      energy_dec=.false.
13261       return
13262       end subroutine egb_long
13263 !-----------------------------------------------------------------------------
13264       subroutine egb_short(evdw)
13265 !
13266 ! This subroutine calculates the interaction energy of nonbonded side chains
13267 ! assuming the Gay-Berne potential of interaction.
13268 !
13269       use calc_data
13270 !      implicit real*8 (a-h,o-z)
13271 !      include 'DIMENSIONS'
13272 !      include 'COMMON.GEO'
13273 !      include 'COMMON.VAR'
13274 !      include 'COMMON.LOCAL'
13275 !      include 'COMMON.CHAIN'
13276 !      include 'COMMON.DERIV'
13277 !      include 'COMMON.NAMES'
13278 !      include 'COMMON.INTERACT'
13279 !      include 'COMMON.IOUNITS'
13280 !      include 'COMMON.CALC'
13281 !      include 'COMMON.CONTROL'
13282       logical :: lprn
13283 !el local variables
13284       integer :: iint,itypi,itypi1,itypj,subchap
13285       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13286       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13287       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13288                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13289                     ssgradlipi,ssgradlipj
13290       evdw=0.0D0
13291 !cccc      energy_dec=.false.
13292 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13293       evdw=0.0D0
13294       lprn=.false.
13295 !     if (icall.eq.0) lprn=.false.
13296 !el      ind=0
13297       do i=iatsc_s,iatsc_e
13298         itypi=itype(i,1)
13299         if (itypi.eq.ntyp1) cycle
13300         itypi1=itype(i+1,1)
13301         xi=c(1,nres+i)
13302         yi=c(2,nres+i)
13303         zi=c(3,nres+i)
13304           xi=mod(xi,boxxsize)
13305           if (xi.lt.0) xi=xi+boxxsize
13306           yi=mod(yi,boxysize)
13307           if (yi.lt.0) yi=yi+boxysize
13308           zi=mod(zi,boxzsize)
13309           if (zi.lt.0) zi=zi+boxzsize
13310        if ((zi.gt.bordlipbot)    &
13311         .and.(zi.lt.bordliptop)) then
13312 !C the energy transfer exist
13313         if (zi.lt.buflipbot) then
13314 !C what fraction I am in
13315          fracinbuf=1.0d0-    &
13316              ((zi-bordlipbot)/lipbufthick)
13317 !C lipbufthick is thickenes of lipid buffore
13318          sslipi=sscalelip(fracinbuf)
13319          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13320         elseif (zi.gt.bufliptop) then
13321          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13322          sslipi=sscalelip(fracinbuf)
13323          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13324         else
13325          sslipi=1.0d0
13326          ssgradlipi=0.0
13327         endif
13328        else
13329          sslipi=0.0d0
13330          ssgradlipi=0.0
13331        endif
13332
13333         dxi=dc_norm(1,nres+i)
13334         dyi=dc_norm(2,nres+i)
13335         dzi=dc_norm(3,nres+i)
13336 !        dsci_inv=dsc_inv(itypi)
13337         dsci_inv=vbld_inv(i+nres)
13338
13339         dxi=dc_norm(1,nres+i)
13340         dyi=dc_norm(2,nres+i)
13341         dzi=dc_norm(3,nres+i)
13342 !        dsci_inv=dsc_inv(itypi)
13343         dsci_inv=vbld_inv(i+nres)
13344 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13345 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13346 !
13347 ! Calculate SC interaction energy.
13348 !
13349         do iint=1,nint_gr(i)
13350           do j=istart(i,iint),iend(i,iint)
13351             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13352               call dyn_ssbond_ene(i,j,evdwij)
13353               evdw=evdw+evdwij
13354               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13355                               'evdw',i,j,evdwij,' ss'
13356              do k=j+1,iend(i,iint)
13357 !C search over all next residues
13358               if (dyn_ss_mask(k)) then
13359 !C check if they are cysteins
13360 !C              write(iout,*) 'k=',k
13361
13362 !c              write(iout,*) "PRZED TRI", evdwij
13363 !               evdwij_przed_tri=evdwij
13364               call triple_ssbond_ene(i,j,k,evdwij)
13365 !c               if(evdwij_przed_tri.ne.evdwij) then
13366 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13367 !c               endif
13368
13369 !c              write(iout,*) "PO TRI", evdwij
13370 !C call the energy function that removes the artifical triple disulfide
13371 !C bond the soubroutine is located in ssMD.F
13372               evdw=evdw+evdwij
13373               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13374                             'evdw',i,j,evdwij,'tss'
13375               endif!dyn_ss_mask(k)
13376              enddo! k
13377
13378 !              if (energy_dec) write (iout,*) &
13379 !                              'evdw',i,j,evdwij,' ss'
13380             ELSE
13381 !el            ind=ind+1
13382             itypj=itype(j,1)
13383             if (itypj.eq.ntyp1) cycle
13384 !            dscj_inv=dsc_inv(itypj)
13385             dscj_inv=vbld_inv(j+nres)
13386 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13387 !     &       1.0d0/vbld(j+nres)
13388 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13389             sig0ij=sigma(itypi,itypj)
13390             chi1=chi(itypi,itypj)
13391             chi2=chi(itypj,itypi)
13392             chi12=chi1*chi2
13393             chip1=chip(itypi)
13394             chip2=chip(itypj)
13395             chip12=chip1*chip2
13396             alf1=alp(itypi)
13397             alf2=alp(itypj)
13398             alf12=0.5D0*(alf1+alf2)
13399 !            xj=c(1,nres+j)-xi
13400 !            yj=c(2,nres+j)-yi
13401 !            zj=c(3,nres+j)-zi
13402             xj=c(1,nres+j)
13403             yj=c(2,nres+j)
13404             zj=c(3,nres+j)
13405 ! Searching for nearest neighbour
13406           xj=mod(xj,boxxsize)
13407           if (xj.lt.0) xj=xj+boxxsize
13408           yj=mod(yj,boxysize)
13409           if (yj.lt.0) yj=yj+boxysize
13410           zj=mod(zj,boxzsize)
13411           if (zj.lt.0) zj=zj+boxzsize
13412        if ((zj.gt.bordlipbot)   &
13413       .and.(zj.lt.bordliptop)) then
13414 !C the energy transfer exist
13415         if (zj.lt.buflipbot) then
13416 !C what fraction I am in
13417          fracinbuf=1.0d0-  &
13418              ((zj-bordlipbot)/lipbufthick)
13419 !C lipbufthick is thickenes of lipid buffore
13420          sslipj=sscalelip(fracinbuf)
13421          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13422         elseif (zj.gt.bufliptop) then
13423          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13424          sslipj=sscalelip(fracinbuf)
13425          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13426         else
13427          sslipj=1.0d0
13428          ssgradlipj=0.0
13429         endif
13430        else
13431          sslipj=0.0d0
13432          ssgradlipj=0.0
13433        endif
13434       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13435        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13436       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13437        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13438
13439           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13440           xj_safe=xj
13441           yj_safe=yj
13442           zj_safe=zj
13443           subchap=0
13444
13445           do xshift=-1,1
13446           do yshift=-1,1
13447           do zshift=-1,1
13448           xj=xj_safe+xshift*boxxsize
13449           yj=yj_safe+yshift*boxysize
13450           zj=zj_safe+zshift*boxzsize
13451           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13452           if(dist_temp.lt.dist_init) then
13453             dist_init=dist_temp
13454             xj_temp=xj
13455             yj_temp=yj
13456             zj_temp=zj
13457             subchap=1
13458           endif
13459           enddo
13460           enddo
13461           enddo
13462           if (subchap.eq.1) then
13463           xj=xj_temp-xi
13464           yj=yj_temp-yi
13465           zj=zj_temp-zi
13466           else
13467           xj=xj_safe-xi
13468           yj=yj_safe-yi
13469           zj=zj_safe-zi
13470           endif
13471
13472             dxj=dc_norm(1,nres+j)
13473             dyj=dc_norm(2,nres+j)
13474             dzj=dc_norm(3,nres+j)
13475             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13476             rij=dsqrt(rrij)
13477             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13478             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13479             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13480             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13481             if (sss_ele_cut.le.0.0) cycle
13482
13483             if (sss.gt.0.0d0) then
13484
13485 ! Calculate angle-dependent terms of energy and contributions to their
13486 ! derivatives.
13487               call sc_angular
13488               sigsq=1.0D0/sigsq
13489               sig=sig0ij*dsqrt(sigsq)
13490               rij_shift=1.0D0/rij-sig+sig0ij
13491 ! for diagnostics; uncomment
13492 !              rij_shift=1.2*sig0ij
13493 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13494               if (rij_shift.le.0.0D0) then
13495                 evdw=1.0D20
13496 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13497 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13498 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13499                 return
13500               endif
13501               sigder=-sig*sigsq
13502 !---------------------------------------------------------------
13503               rij_shift=1.0D0/rij_shift
13504               fac=rij_shift**expon
13505               e1=fac*fac*aa
13506               e2=fac*bb
13507               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13508               eps2der=evdwij*eps3rt
13509               eps3der=evdwij*eps2rt
13510 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13511 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13512               evdwij=evdwij*eps2rt*eps3rt
13513               evdw=evdw+evdwij*sss*sss_ele_cut
13514               if (lprn) then
13515               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13516               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13517               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13518                 restyp(itypi,1),i,restyp(itypj,1),j,&
13519                 epsi,sigm,chi1,chi2,chip1,chip2,&
13520                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13521                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13522                 evdwij
13523               endif
13524
13525               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13526                               'evdw',i,j,evdwij
13527 !              if (energy_dec) write (iout,*) &
13528 !                              'evdw',i,j,evdwij,"egb_short"
13529
13530 ! Calculate gradient components.
13531               e1=e1*eps1*eps2rt**2*eps3rt**2
13532               fac=-expon*(e1+evdwij)*rij_shift
13533               sigder=fac*sigder
13534               fac=rij*fac
13535               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13536             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13537             /sigmaii(itypi,itypj))
13538
13539 !              fac=0.0d0
13540 ! Calculate the radial part of the gradient
13541               gg(1)=xj*fac
13542               gg(2)=yj*fac
13543               gg(3)=zj*fac
13544 ! Calculate angular part of the gradient.
13545               call sc_grad_scale(sss)
13546             endif
13547           ENDIF !mask_dyn_ss
13548           enddo      ! j
13549         enddo        ! iint
13550       enddo          ! i
13551 !      write (iout,*) "Number of loop steps in EGB:",ind
13552 !ccc      energy_dec=.false.
13553       return
13554       end subroutine egb_short
13555 !-----------------------------------------------------------------------------
13556       subroutine egbv_long(evdw)
13557 !
13558 ! This subroutine calculates the interaction energy of nonbonded side chains
13559 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13560 !
13561       use calc_data
13562 !      implicit real*8 (a-h,o-z)
13563 !      include 'DIMENSIONS'
13564 !      include 'COMMON.GEO'
13565 !      include 'COMMON.VAR'
13566 !      include 'COMMON.LOCAL'
13567 !      include 'COMMON.CHAIN'
13568 !      include 'COMMON.DERIV'
13569 !      include 'COMMON.NAMES'
13570 !      include 'COMMON.INTERACT'
13571 !      include 'COMMON.IOUNITS'
13572 !      include 'COMMON.CALC'
13573       use comm_srutu
13574 !el      integer :: icall
13575 !el      common /srutu/ icall
13576       logical :: lprn
13577 !el local variables
13578       integer :: iint,itypi,itypi1,itypj
13579       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13580       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13581       evdw=0.0D0
13582 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13583       evdw=0.0D0
13584       lprn=.false.
13585 !     if (icall.eq.0) lprn=.true.
13586 !el      ind=0
13587       do i=iatsc_s,iatsc_e
13588         itypi=itype(i,1)
13589         if (itypi.eq.ntyp1) cycle
13590         itypi1=itype(i+1,1)
13591         xi=c(1,nres+i)
13592         yi=c(2,nres+i)
13593         zi=c(3,nres+i)
13594         dxi=dc_norm(1,nres+i)
13595         dyi=dc_norm(2,nres+i)
13596         dzi=dc_norm(3,nres+i)
13597 !        dsci_inv=dsc_inv(itypi)
13598         dsci_inv=vbld_inv(i+nres)
13599 !
13600 ! Calculate SC interaction energy.
13601 !
13602         do iint=1,nint_gr(i)
13603           do j=istart(i,iint),iend(i,iint)
13604 !el            ind=ind+1
13605             itypj=itype(j,1)
13606             if (itypj.eq.ntyp1) cycle
13607 !            dscj_inv=dsc_inv(itypj)
13608             dscj_inv=vbld_inv(j+nres)
13609             sig0ij=sigma(itypi,itypj)
13610             r0ij=r0(itypi,itypj)
13611             chi1=chi(itypi,itypj)
13612             chi2=chi(itypj,itypi)
13613             chi12=chi1*chi2
13614             chip1=chip(itypi)
13615             chip2=chip(itypj)
13616             chip12=chip1*chip2
13617             alf1=alp(itypi)
13618             alf2=alp(itypj)
13619             alf12=0.5D0*(alf1+alf2)
13620             xj=c(1,nres+j)-xi
13621             yj=c(2,nres+j)-yi
13622             zj=c(3,nres+j)-zi
13623             dxj=dc_norm(1,nres+j)
13624             dyj=dc_norm(2,nres+j)
13625             dzj=dc_norm(3,nres+j)
13626             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13627             rij=dsqrt(rrij)
13628
13629             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13630
13631             if (sss.lt.1.0d0) then
13632
13633 ! Calculate angle-dependent terms of energy and contributions to their
13634 ! derivatives.
13635               call sc_angular
13636               sigsq=1.0D0/sigsq
13637               sig=sig0ij*dsqrt(sigsq)
13638               rij_shift=1.0D0/rij-sig+r0ij
13639 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13640               if (rij_shift.le.0.0D0) then
13641                 evdw=1.0D20
13642                 return
13643               endif
13644               sigder=-sig*sigsq
13645 !---------------------------------------------------------------
13646               rij_shift=1.0D0/rij_shift
13647               fac=rij_shift**expon
13648               e1=fac*fac*aa_aq(itypi,itypj)
13649               e2=fac*bb_aq(itypi,itypj)
13650               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13651               eps2der=evdwij*eps3rt
13652               eps3der=evdwij*eps2rt
13653               fac_augm=rrij**expon
13654               e_augm=augm(itypi,itypj)*fac_augm
13655               evdwij=evdwij*eps2rt*eps3rt
13656               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13657               if (lprn) then
13658               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13659               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13660               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13661                 restyp(itypi,1),i,restyp(itypj,1),j,&
13662                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13663                 chi1,chi2,chip1,chip2,&
13664                 eps1,eps2rt**2,eps3rt**2,&
13665                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13666                 evdwij+e_augm
13667               endif
13668 ! Calculate gradient components.
13669               e1=e1*eps1*eps2rt**2*eps3rt**2
13670               fac=-expon*(e1+evdwij)*rij_shift
13671               sigder=fac*sigder
13672               fac=rij*fac-2*expon*rrij*e_augm
13673 ! Calculate the radial part of the gradient
13674               gg(1)=xj*fac
13675               gg(2)=yj*fac
13676               gg(3)=zj*fac
13677 ! Calculate angular part of the gradient.
13678               call sc_grad_scale(1.0d0-sss)
13679             endif
13680           enddo      ! j
13681         enddo        ! iint
13682       enddo          ! i
13683       end subroutine egbv_long
13684 !-----------------------------------------------------------------------------
13685       subroutine egbv_short(evdw)
13686 !
13687 ! This subroutine calculates the interaction energy of nonbonded side chains
13688 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13689 !
13690       use calc_data
13691 !      implicit real*8 (a-h,o-z)
13692 !      include 'DIMENSIONS'
13693 !      include 'COMMON.GEO'
13694 !      include 'COMMON.VAR'
13695 !      include 'COMMON.LOCAL'
13696 !      include 'COMMON.CHAIN'
13697 !      include 'COMMON.DERIV'
13698 !      include 'COMMON.NAMES'
13699 !      include 'COMMON.INTERACT'
13700 !      include 'COMMON.IOUNITS'
13701 !      include 'COMMON.CALC'
13702       use comm_srutu
13703 !el      integer :: icall
13704 !el      common /srutu/ icall
13705       logical :: lprn
13706 !el local variables
13707       integer :: iint,itypi,itypi1,itypj
13708       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13709       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13710       evdw=0.0D0
13711 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13712       evdw=0.0D0
13713       lprn=.false.
13714 !     if (icall.eq.0) lprn=.true.
13715 !el      ind=0
13716       do i=iatsc_s,iatsc_e
13717         itypi=itype(i,1)
13718         if (itypi.eq.ntyp1) cycle
13719         itypi1=itype(i+1,1)
13720         xi=c(1,nres+i)
13721         yi=c(2,nres+i)
13722         zi=c(3,nres+i)
13723         dxi=dc_norm(1,nres+i)
13724         dyi=dc_norm(2,nres+i)
13725         dzi=dc_norm(3,nres+i)
13726 !        dsci_inv=dsc_inv(itypi)
13727         dsci_inv=vbld_inv(i+nres)
13728 !
13729 ! Calculate SC interaction energy.
13730 !
13731         do iint=1,nint_gr(i)
13732           do j=istart(i,iint),iend(i,iint)
13733 !el            ind=ind+1
13734             itypj=itype(j,1)
13735             if (itypj.eq.ntyp1) cycle
13736 !            dscj_inv=dsc_inv(itypj)
13737             dscj_inv=vbld_inv(j+nres)
13738             sig0ij=sigma(itypi,itypj)
13739             r0ij=r0(itypi,itypj)
13740             chi1=chi(itypi,itypj)
13741             chi2=chi(itypj,itypi)
13742             chi12=chi1*chi2
13743             chip1=chip(itypi)
13744             chip2=chip(itypj)
13745             chip12=chip1*chip2
13746             alf1=alp(itypi)
13747             alf2=alp(itypj)
13748             alf12=0.5D0*(alf1+alf2)
13749             xj=c(1,nres+j)-xi
13750             yj=c(2,nres+j)-yi
13751             zj=c(3,nres+j)-zi
13752             dxj=dc_norm(1,nres+j)
13753             dyj=dc_norm(2,nres+j)
13754             dzj=dc_norm(3,nres+j)
13755             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13756             rij=dsqrt(rrij)
13757
13758             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13759
13760             if (sss.gt.0.0d0) then
13761
13762 ! Calculate angle-dependent terms of energy and contributions to their
13763 ! derivatives.
13764               call sc_angular
13765               sigsq=1.0D0/sigsq
13766               sig=sig0ij*dsqrt(sigsq)
13767               rij_shift=1.0D0/rij-sig+r0ij
13768 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13769               if (rij_shift.le.0.0D0) then
13770                 evdw=1.0D20
13771                 return
13772               endif
13773               sigder=-sig*sigsq
13774 !---------------------------------------------------------------
13775               rij_shift=1.0D0/rij_shift
13776               fac=rij_shift**expon
13777               e1=fac*fac*aa_aq(itypi,itypj)
13778               e2=fac*bb_aq(itypi,itypj)
13779               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13780               eps2der=evdwij*eps3rt
13781               eps3der=evdwij*eps2rt
13782               fac_augm=rrij**expon
13783               e_augm=augm(itypi,itypj)*fac_augm
13784               evdwij=evdwij*eps2rt*eps3rt
13785               evdw=evdw+(evdwij+e_augm)*sss
13786               if (lprn) then
13787               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13788               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13789               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13790                 restyp(itypi,1),i,restyp(itypj,1),j,&
13791                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13792                 chi1,chi2,chip1,chip2,&
13793                 eps1,eps2rt**2,eps3rt**2,&
13794                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13795                 evdwij+e_augm
13796               endif
13797 ! Calculate gradient components.
13798               e1=e1*eps1*eps2rt**2*eps3rt**2
13799               fac=-expon*(e1+evdwij)*rij_shift
13800               sigder=fac*sigder
13801               fac=rij*fac-2*expon*rrij*e_augm
13802 ! Calculate the radial part of the gradient
13803               gg(1)=xj*fac
13804               gg(2)=yj*fac
13805               gg(3)=zj*fac
13806 ! Calculate angular part of the gradient.
13807               call sc_grad_scale(sss)
13808             endif
13809           enddo      ! j
13810         enddo        ! iint
13811       enddo          ! i
13812       end subroutine egbv_short
13813 !-----------------------------------------------------------------------------
13814       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13815 !
13816 ! This subroutine calculates the average interaction energy and its gradient
13817 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13818 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13819 ! The potential depends both on the distance of peptide-group centers and on
13820 ! the orientation of the CA-CA virtual bonds.
13821 !
13822 !      implicit real*8 (a-h,o-z)
13823
13824       use comm_locel
13825 #ifdef MPI
13826       include 'mpif.h'
13827 #endif
13828 !      include 'DIMENSIONS'
13829 !      include 'COMMON.CONTROL'
13830 !      include 'COMMON.SETUP'
13831 !      include 'COMMON.IOUNITS'
13832 !      include 'COMMON.GEO'
13833 !      include 'COMMON.VAR'
13834 !      include 'COMMON.LOCAL'
13835 !      include 'COMMON.CHAIN'
13836 !      include 'COMMON.DERIV'
13837 !      include 'COMMON.INTERACT'
13838 !      include 'COMMON.CONTACTS'
13839 !      include 'COMMON.TORSION'
13840 !      include 'COMMON.VECTORS'
13841 !      include 'COMMON.FFIELD'
13842 !      include 'COMMON.TIME1'
13843       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13844       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13845       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13846 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13847       real(kind=8),dimension(4) :: muij
13848 !el      integer :: num_conti,j1,j2
13849 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13850 !el                   dz_normi,xmedi,ymedi,zmedi
13851 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13852 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13853 !el          num_conti,j1,j2
13854 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13855 #ifdef MOMENT
13856       real(kind=8) :: scal_el=1.0d0
13857 #else
13858       real(kind=8) :: scal_el=0.5d0
13859 #endif
13860 ! 12/13/98
13861 ! 13-go grudnia roku pamietnego...
13862       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13863                                              0.0d0,1.0d0,0.0d0,&
13864                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13865 !el local variables
13866       integer :: i,j,k
13867       real(kind=8) :: fac
13868       real(kind=8) :: dxj,dyj,dzj
13869       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13870
13871 !      allocate(num_cont_hb(nres)) !(maxres)
13872 !d      write(iout,*) 'In EELEC'
13873 !d      do i=1,nloctyp
13874 !d        write(iout,*) 'Type',i
13875 !d        write(iout,*) 'B1',B1(:,i)
13876 !d        write(iout,*) 'B2',B2(:,i)
13877 !d        write(iout,*) 'CC',CC(:,:,i)
13878 !d        write(iout,*) 'DD',DD(:,:,i)
13879 !d        write(iout,*) 'EE',EE(:,:,i)
13880 !d      enddo
13881 !d      call check_vecgrad
13882 !d      stop
13883       if (icheckgrad.eq.1) then
13884         do i=1,nres-1
13885           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13886           do k=1,3
13887             dc_norm(k,i)=dc(k,i)*fac
13888           enddo
13889 !          write (iout,*) 'i',i,' fac',fac
13890         enddo
13891       endif
13892       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13893           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13894           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13895 !        call vec_and_deriv
13896 #ifdef TIMING
13897         time01=MPI_Wtime()
13898 #endif
13899 !        print *, "before set matrices"
13900         call set_matrices
13901 !        print *,"after set martices"
13902 #ifdef TIMING
13903         time_mat=time_mat+MPI_Wtime()-time01
13904 #endif
13905       endif
13906 !d      do i=1,nres-1
13907 !d        write (iout,*) 'i=',i
13908 !d        do k=1,3
13909 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
13910 !d        enddo
13911 !d        do k=1,3
13912 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
13913 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
13914 !d        enddo
13915 !d      enddo
13916       t_eelecij=0.0d0
13917       ees=0.0D0
13918       evdw1=0.0D0
13919       eel_loc=0.0d0
13920       eello_turn3=0.0d0
13921       eello_turn4=0.0d0
13922 !el      ind=0
13923       do i=1,nres
13924         num_cont_hb(i)=0
13925       enddo
13926 !d      print '(a)','Enter EELEC'
13927 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
13928 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13929 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13930       do i=1,nres
13931         gel_loc_loc(i)=0.0d0
13932         gcorr_loc(i)=0.0d0
13933       enddo
13934 !
13935 !
13936 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
13937 !
13938 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
13939 !
13940       do i=iturn3_start,iturn3_end
13941         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
13942         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
13943         dxi=dc(1,i)
13944         dyi=dc(2,i)
13945         dzi=dc(3,i)
13946         dx_normi=dc_norm(1,i)
13947         dy_normi=dc_norm(2,i)
13948         dz_normi=dc_norm(3,i)
13949         xmedi=c(1,i)+0.5d0*dxi
13950         ymedi=c(2,i)+0.5d0*dyi
13951         zmedi=c(3,i)+0.5d0*dzi
13952           xmedi=dmod(xmedi,boxxsize)
13953           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13954           ymedi=dmod(ymedi,boxysize)
13955           if (ymedi.lt.0) ymedi=ymedi+boxysize
13956           zmedi=dmod(zmedi,boxzsize)
13957           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13958         num_conti=0
13959         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
13960         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
13961         num_cont_hb(i)=num_conti
13962       enddo
13963       do i=iturn4_start,iturn4_end
13964         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
13965           .or. itype(i+3,1).eq.ntyp1 &
13966           .or. itype(i+4,1).eq.ntyp1) cycle
13967         dxi=dc(1,i)
13968         dyi=dc(2,i)
13969         dzi=dc(3,i)
13970         dx_normi=dc_norm(1,i)
13971         dy_normi=dc_norm(2,i)
13972         dz_normi=dc_norm(3,i)
13973         xmedi=c(1,i)+0.5d0*dxi
13974         ymedi=c(2,i)+0.5d0*dyi
13975         zmedi=c(3,i)+0.5d0*dzi
13976           xmedi=dmod(xmedi,boxxsize)
13977           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13978           ymedi=dmod(ymedi,boxysize)
13979           if (ymedi.lt.0) ymedi=ymedi+boxysize
13980           zmedi=dmod(zmedi,boxzsize)
13981           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13982         num_conti=num_cont_hb(i)
13983         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
13984         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
13985           call eturn4(i,eello_turn4)
13986         num_cont_hb(i)=num_conti
13987       enddo   ! i
13988 !
13989 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
13990 !
13991       do i=iatel_s,iatel_e
13992         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
13993         dxi=dc(1,i)
13994         dyi=dc(2,i)
13995         dzi=dc(3,i)
13996         dx_normi=dc_norm(1,i)
13997         dy_normi=dc_norm(2,i)
13998         dz_normi=dc_norm(3,i)
13999         xmedi=c(1,i)+0.5d0*dxi
14000         ymedi=c(2,i)+0.5d0*dyi
14001         zmedi=c(3,i)+0.5d0*dzi
14002           xmedi=dmod(xmedi,boxxsize)
14003           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14004           ymedi=dmod(ymedi,boxysize)
14005           if (ymedi.lt.0) ymedi=ymedi+boxysize
14006           zmedi=dmod(zmedi,boxzsize)
14007           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14008 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14009         num_conti=num_cont_hb(i)
14010         do j=ielstart(i),ielend(i)
14011           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14012           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14013         enddo ! j
14014         num_cont_hb(i)=num_conti
14015       enddo   ! i
14016 !      write (iout,*) "Number of loop steps in EELEC:",ind
14017 !d      do i=1,nres
14018 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14019 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14020 !d      enddo
14021 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14022 !cc      eel_loc=eel_loc+eello_turn3
14023 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14024       return
14025       end subroutine eelec_scale
14026 !-----------------------------------------------------------------------------
14027       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14028 !      implicit real*8 (a-h,o-z)
14029
14030       use comm_locel
14031 !      include 'DIMENSIONS'
14032 #ifdef MPI
14033       include "mpif.h"
14034 #endif
14035 !      include 'COMMON.CONTROL'
14036 !      include 'COMMON.IOUNITS'
14037 !      include 'COMMON.GEO'
14038 !      include 'COMMON.VAR'
14039 !      include 'COMMON.LOCAL'
14040 !      include 'COMMON.CHAIN'
14041 !      include 'COMMON.DERIV'
14042 !      include 'COMMON.INTERACT'
14043 !      include 'COMMON.CONTACTS'
14044 !      include 'COMMON.TORSION'
14045 !      include 'COMMON.VECTORS'
14046 !      include 'COMMON.FFIELD'
14047 !      include 'COMMON.TIME1'
14048       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14049       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14050       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14051 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14052       real(kind=8),dimension(4) :: muij
14053       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14054                     dist_temp, dist_init,sss_grad
14055       integer xshift,yshift,zshift
14056
14057 !el      integer :: num_conti,j1,j2
14058 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14059 !el                   dz_normi,xmedi,ymedi,zmedi
14060 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14061 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14062 !el          num_conti,j1,j2
14063 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14064 #ifdef MOMENT
14065       real(kind=8) :: scal_el=1.0d0
14066 #else
14067       real(kind=8) :: scal_el=0.5d0
14068 #endif
14069 ! 12/13/98
14070 ! 13-go grudnia roku pamietnego...
14071       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14072                                              0.0d0,1.0d0,0.0d0,&
14073                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14074 !el local variables
14075       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14076       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14077       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14078       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14079       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14080       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14081       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14082                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14083                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14084                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14085                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14086                   ecosam,ecosbm,ecosgm,ghalf,time00
14087 !      integer :: maxconts
14088 !      maxconts = nres/4
14089 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14090 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14091 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14092 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14093 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14094 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14095 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14096 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14097 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14098 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14099 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14100 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14101 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14102
14103 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14104 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14105
14106 #ifdef MPI
14107           time00=MPI_Wtime()
14108 #endif
14109 !d      write (iout,*) "eelecij",i,j
14110 !el          ind=ind+1
14111           iteli=itel(i)
14112           itelj=itel(j)
14113           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14114           aaa=app(iteli,itelj)
14115           bbb=bpp(iteli,itelj)
14116           ael6i=ael6(iteli,itelj)
14117           ael3i=ael3(iteli,itelj)
14118           dxj=dc(1,j)
14119           dyj=dc(2,j)
14120           dzj=dc(3,j)
14121           dx_normj=dc_norm(1,j)
14122           dy_normj=dc_norm(2,j)
14123           dz_normj=dc_norm(3,j)
14124 !          xj=c(1,j)+0.5D0*dxj-xmedi
14125 !          yj=c(2,j)+0.5D0*dyj-ymedi
14126 !          zj=c(3,j)+0.5D0*dzj-zmedi
14127           xj=c(1,j)+0.5D0*dxj
14128           yj=c(2,j)+0.5D0*dyj
14129           zj=c(3,j)+0.5D0*dzj
14130           xj=mod(xj,boxxsize)
14131           if (xj.lt.0) xj=xj+boxxsize
14132           yj=mod(yj,boxysize)
14133           if (yj.lt.0) yj=yj+boxysize
14134           zj=mod(zj,boxzsize)
14135           if (zj.lt.0) zj=zj+boxzsize
14136       isubchap=0
14137       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14138       xj_safe=xj
14139       yj_safe=yj
14140       zj_safe=zj
14141       do xshift=-1,1
14142       do yshift=-1,1
14143       do zshift=-1,1
14144           xj=xj_safe+xshift*boxxsize
14145           yj=yj_safe+yshift*boxysize
14146           zj=zj_safe+zshift*boxzsize
14147           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14148           if(dist_temp.lt.dist_init) then
14149             dist_init=dist_temp
14150             xj_temp=xj
14151             yj_temp=yj
14152             zj_temp=zj
14153             isubchap=1
14154           endif
14155        enddo
14156        enddo
14157        enddo
14158        if (isubchap.eq.1) then
14159 !C          print *,i,j
14160           xj=xj_temp-xmedi
14161           yj=yj_temp-ymedi
14162           zj=zj_temp-zmedi
14163        else
14164           xj=xj_safe-xmedi
14165           yj=yj_safe-ymedi
14166           zj=zj_safe-zmedi
14167        endif
14168
14169           rij=xj*xj+yj*yj+zj*zj
14170           rrmij=1.0D0/rij
14171           rij=dsqrt(rij)
14172           rmij=1.0D0/rij
14173 ! For extracting the short-range part of Evdwpp
14174           sss=sscale(rij/rpp(iteli,itelj))
14175             sss_ele_cut=sscale_ele(rij)
14176             sss_ele_grad=sscagrad_ele(rij)
14177             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14178 !             sss_ele_cut=1.0d0
14179 !             sss_ele_grad=0.0d0
14180             if (sss_ele_cut.le.0.0) go to 128
14181
14182           r3ij=rrmij*rmij
14183           r6ij=r3ij*r3ij
14184           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14185           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14186           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14187           fac=cosa-3.0D0*cosb*cosg
14188           ev1=aaa*r6ij*r6ij
14189 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14190           if (j.eq.i+2) ev1=scal_el*ev1
14191           ev2=bbb*r6ij
14192           fac3=ael6i*r6ij
14193           fac4=ael3i*r3ij
14194           evdwij=ev1+ev2
14195           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14196           el2=fac4*fac
14197           eesij=el1+el2
14198 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14199           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14200           ees=ees+eesij*sss_ele_cut
14201           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14202 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14203 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14204 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14205 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14206
14207           if (energy_dec) then
14208               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14209               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14210           endif
14211
14212 !
14213 ! Calculate contributions to the Cartesian gradient.
14214 !
14215 #ifdef SPLITELE
14216           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14217           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14218           fac1=fac
14219           erij(1)=xj*rmij
14220           erij(2)=yj*rmij
14221           erij(3)=zj*rmij
14222 !
14223 ! Radial derivatives. First process both termini of the fragment (i,j)
14224 !
14225           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14226           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14227           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14228 !          do k=1,3
14229 !            ghalf=0.5D0*ggg(k)
14230 !            gelc(k,i)=gelc(k,i)+ghalf
14231 !            gelc(k,j)=gelc(k,j)+ghalf
14232 !          enddo
14233 ! 9/28/08 AL Gradient compotents will be summed only at the end
14234           do k=1,3
14235             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14236             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14237           enddo
14238 !
14239 ! Loop over residues i+1 thru j-1.
14240 !
14241 !grad          do k=i+1,j-1
14242 !grad            do l=1,3
14243 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14244 !grad            enddo
14245 !grad          enddo
14246           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14247           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14248           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14249           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14250           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14251           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14252 !          do k=1,3
14253 !            ghalf=0.5D0*ggg(k)
14254 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14255 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14256 !          enddo
14257 ! 9/28/08 AL Gradient compotents will be summed only at the end
14258           do k=1,3
14259             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14260             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14261           enddo
14262 !
14263 ! Loop over residues i+1 thru j-1.
14264 !
14265 !grad          do k=i+1,j-1
14266 !grad            do l=1,3
14267 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14268 !grad            enddo
14269 !grad          enddo
14270 #else
14271           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14272           facel=(el1+eesij)*sss_ele_cut
14273           fac1=fac
14274           fac=-3*rrmij*(facvdw+facvdw+facel)
14275           erij(1)=xj*rmij
14276           erij(2)=yj*rmij
14277           erij(3)=zj*rmij
14278 !
14279 ! Radial derivatives. First process both termini of the fragment (i,j)
14280 !
14281           ggg(1)=fac*xj
14282           ggg(2)=fac*yj
14283           ggg(3)=fac*zj
14284 !          do k=1,3
14285 !            ghalf=0.5D0*ggg(k)
14286 !            gelc(k,i)=gelc(k,i)+ghalf
14287 !            gelc(k,j)=gelc(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             gelc_long(k,j)=gelc(k,j)+ggg(k)
14292             gelc_long(k,i)=gelc(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              gelc(l,k)=gelc(l,k)+ggg(l)
14300 !grad            enddo
14301 !grad          enddo
14302 ! 9/28/08 AL Gradient compotents will be summed only at the end
14303           ggg(1)=facvdw*xj
14304           ggg(2)=facvdw*yj
14305           ggg(3)=facvdw*zj
14306           do k=1,3
14307             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14308             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14309           enddo
14310 #endif
14311 !
14312 ! Angular part
14313 !
14314           ecosa=2.0D0*fac3*fac1+fac4
14315           fac4=-3.0D0*fac4
14316           fac3=-6.0D0*fac3
14317           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14318           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14319           do k=1,3
14320             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14321             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14322           enddo
14323 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14324 !d   &          (dcosg(k),k=1,3)
14325           do k=1,3
14326             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14327           enddo
14328 !          do k=1,3
14329 !            ghalf=0.5D0*ggg(k)
14330 !            gelc(k,i)=gelc(k,i)+ghalf
14331 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14332 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14333 !            gelc(k,j)=gelc(k,j)+ghalf
14334 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14335 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14336 !          enddo
14337 !grad          do k=i+1,j-1
14338 !grad            do l=1,3
14339 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14340 !grad            enddo
14341 !grad          enddo
14342           do k=1,3
14343             gelc(k,i)=gelc(k,i) &
14344                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14345                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14346                      *sss_ele_cut
14347             gelc(k,j)=gelc(k,j) &
14348                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14349                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14350                      *sss_ele_cut
14351             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14352             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14353           enddo
14354           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14355               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14356               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14357 !
14358 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14359 !   energy of a peptide unit is assumed in the form of a second-order
14360 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14361 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14362 !   are computed for EVERY pair of non-contiguous peptide groups.
14363 !
14364           if (j.lt.nres-1) then
14365             j1=j+1
14366             j2=j-1
14367           else
14368             j1=j-1
14369             j2=j-2
14370           endif
14371           kkk=0
14372           do k=1,2
14373             do l=1,2
14374               kkk=kkk+1
14375               muij(kkk)=mu(k,i)*mu(l,j)
14376             enddo
14377           enddo
14378 !d         write (iout,*) 'EELEC: i',i,' j',j
14379 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14380 !d          write(iout,*) 'muij',muij
14381           ury=scalar(uy(1,i),erij)
14382           urz=scalar(uz(1,i),erij)
14383           vry=scalar(uy(1,j),erij)
14384           vrz=scalar(uz(1,j),erij)
14385           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14386           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14387           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14388           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14389           fac=dsqrt(-ael6i)*r3ij
14390           a22=a22*fac
14391           a23=a23*fac
14392           a32=a32*fac
14393           a33=a33*fac
14394 !d          write (iout,'(4i5,4f10.5)')
14395 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14396 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14397 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14398 !d     &      uy(:,j),uz(:,j)
14399 !d          write (iout,'(4f10.5)')
14400 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14401 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14402 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14403 !d           write (iout,'(9f10.5/)')
14404 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14405 ! Derivatives of the elements of A in virtual-bond vectors
14406           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14407           do k=1,3
14408             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14409             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14410             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14411             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14412             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14413             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14414             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14415             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14416             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14417             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14418             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14419             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14420           enddo
14421 ! Compute radial contributions to the gradient
14422           facr=-3.0d0*rrmij
14423           a22der=a22*facr
14424           a23der=a23*facr
14425           a32der=a32*facr
14426           a33der=a33*facr
14427           agg(1,1)=a22der*xj
14428           agg(2,1)=a22der*yj
14429           agg(3,1)=a22der*zj
14430           agg(1,2)=a23der*xj
14431           agg(2,2)=a23der*yj
14432           agg(3,2)=a23der*zj
14433           agg(1,3)=a32der*xj
14434           agg(2,3)=a32der*yj
14435           agg(3,3)=a32der*zj
14436           agg(1,4)=a33der*xj
14437           agg(2,4)=a33der*yj
14438           agg(3,4)=a33der*zj
14439 ! Add the contributions coming from er
14440           fac3=-3.0d0*fac
14441           do k=1,3
14442             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14443             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14444             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14445             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14446           enddo
14447           do k=1,3
14448 ! Derivatives in DC(i)
14449 !grad            ghalf1=0.5d0*agg(k,1)
14450 !grad            ghalf2=0.5d0*agg(k,2)
14451 !grad            ghalf3=0.5d0*agg(k,3)
14452 !grad            ghalf4=0.5d0*agg(k,4)
14453             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14454             -3.0d0*uryg(k,2)*vry)!+ghalf1
14455             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14456             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14457             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14458             -3.0d0*urzg(k,2)*vry)!+ghalf3
14459             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14460             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14461 ! Derivatives in DC(i+1)
14462             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14463             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14464             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14465             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14466             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14467             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14468             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14469             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14470 ! Derivatives in DC(j)
14471             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14472             -3.0d0*vryg(k,2)*ury)!+ghalf1
14473             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14474             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14475             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14476             -3.0d0*vryg(k,2)*urz)!+ghalf3
14477             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14478             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14479 ! Derivatives in DC(j+1) or DC(nres-1)
14480             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14481             -3.0d0*vryg(k,3)*ury)
14482             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14483             -3.0d0*vrzg(k,3)*ury)
14484             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14485             -3.0d0*vryg(k,3)*urz)
14486             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14487             -3.0d0*vrzg(k,3)*urz)
14488 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14489 !grad              do l=1,4
14490 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14491 !grad              enddo
14492 !grad            endif
14493           enddo
14494           acipa(1,1)=a22
14495           acipa(1,2)=a23
14496           acipa(2,1)=a32
14497           acipa(2,2)=a33
14498           a22=-a22
14499           a23=-a23
14500           do l=1,2
14501             do k=1,3
14502               agg(k,l)=-agg(k,l)
14503               aggi(k,l)=-aggi(k,l)
14504               aggi1(k,l)=-aggi1(k,l)
14505               aggj(k,l)=-aggj(k,l)
14506               aggj1(k,l)=-aggj1(k,l)
14507             enddo
14508           enddo
14509           if (j.lt.nres-1) then
14510             a22=-a22
14511             a32=-a32
14512             do l=1,3,2
14513               do k=1,3
14514                 agg(k,l)=-agg(k,l)
14515                 aggi(k,l)=-aggi(k,l)
14516                 aggi1(k,l)=-aggi1(k,l)
14517                 aggj(k,l)=-aggj(k,l)
14518                 aggj1(k,l)=-aggj1(k,l)
14519               enddo
14520             enddo
14521           else
14522             a22=-a22
14523             a23=-a23
14524             a32=-a32
14525             a33=-a33
14526             do l=1,4
14527               do k=1,3
14528                 agg(k,l)=-agg(k,l)
14529                 aggi(k,l)=-aggi(k,l)
14530                 aggi1(k,l)=-aggi1(k,l)
14531                 aggj(k,l)=-aggj(k,l)
14532                 aggj1(k,l)=-aggj1(k,l)
14533               enddo
14534             enddo
14535           endif
14536           ENDIF ! WCORR
14537           IF (wel_loc.gt.0.0d0) THEN
14538 ! Contribution to the local-electrostatic energy coming from the i-j pair
14539           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14540            +a33*muij(4)
14541 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14542
14543           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14544                   'eelloc',i,j,eel_loc_ij
14545 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14546
14547           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14548 ! Partial derivatives in virtual-bond dihedral angles gamma
14549           if (i.gt.1) &
14550           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14551                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14552                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14553                  *sss_ele_cut
14554           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14555                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14556                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14557                  *sss_ele_cut
14558            xtemp(1)=xj
14559            xtemp(2)=yj
14560            xtemp(3)=zj
14561
14562 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14563           do l=1,3
14564             ggg(l)=(agg(l,1)*muij(1)+ &
14565                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14566             *sss_ele_cut &
14567              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14568
14569             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14570             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14571 !grad            ghalf=0.5d0*ggg(l)
14572 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14573 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14574           enddo
14575 !grad          do k=i+1,j2
14576 !grad            do l=1,3
14577 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14578 !grad            enddo
14579 !grad          enddo
14580 ! Remaining derivatives of eello
14581           do l=1,3
14582             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14583                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14584             *sss_ele_cut
14585
14586             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14587                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14588             *sss_ele_cut
14589
14590             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14591                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14592             *sss_ele_cut
14593
14594             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14595                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14596             *sss_ele_cut
14597
14598           enddo
14599           ENDIF
14600 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14601 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14602           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14603              .and. num_conti.le.maxconts) then
14604 !            write (iout,*) i,j," entered corr"
14605 !
14606 ! Calculate the contact function. The ith column of the array JCONT will
14607 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14608 ! greater than I). The arrays FACONT and GACONT will contain the values of
14609 ! the contact function and its derivative.
14610 !           r0ij=1.02D0*rpp(iteli,itelj)
14611 !           r0ij=1.11D0*rpp(iteli,itelj)
14612             r0ij=2.20D0*rpp(iteli,itelj)
14613 !           r0ij=1.55D0*rpp(iteli,itelj)
14614             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14615 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14616             if (fcont.gt.0.0D0) then
14617               num_conti=num_conti+1
14618               if (num_conti.gt.maxconts) then
14619 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14620                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14621                                ' will skip next contacts for this conf.',num_conti
14622               else
14623                 jcont_hb(num_conti,i)=j
14624 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14625 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14626                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14627                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14628 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14629 !  terms.
14630                 d_cont(num_conti,i)=rij
14631 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14632 !     --- Electrostatic-interaction matrix ---
14633                 a_chuj(1,1,num_conti,i)=a22
14634                 a_chuj(1,2,num_conti,i)=a23
14635                 a_chuj(2,1,num_conti,i)=a32
14636                 a_chuj(2,2,num_conti,i)=a33
14637 !     --- Gradient of rij
14638                 do kkk=1,3
14639                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14640                 enddo
14641                 kkll=0
14642                 do k=1,2
14643                   do l=1,2
14644                     kkll=kkll+1
14645                     do m=1,3
14646                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14647                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14648                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14649                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14650                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14651                     enddo
14652                   enddo
14653                 enddo
14654                 ENDIF
14655                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14656 ! Calculate contact energies
14657                 cosa4=4.0D0*cosa
14658                 wij=cosa-3.0D0*cosb*cosg
14659                 cosbg1=cosb+cosg
14660                 cosbg2=cosb-cosg
14661 !               fac3=dsqrt(-ael6i)/r0ij**3
14662                 fac3=dsqrt(-ael6i)*r3ij
14663 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14664                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14665                 if (ees0tmp.gt.0) then
14666                   ees0pij=dsqrt(ees0tmp)
14667                 else
14668                   ees0pij=0
14669                 endif
14670 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14671                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14672                 if (ees0tmp.gt.0) then
14673                   ees0mij=dsqrt(ees0tmp)
14674                 else
14675                   ees0mij=0
14676                 endif
14677 !               ees0mij=0.0D0
14678                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14679                      *sss_ele_cut
14680
14681                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14682                      *sss_ele_cut
14683
14684 ! Diagnostics. Comment out or remove after debugging!
14685 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14686 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14687 !               ees0m(num_conti,i)=0.0D0
14688 ! End diagnostics.
14689 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14690 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14691 ! Angular derivatives of the contact function
14692                 ees0pij1=fac3/ees0pij
14693                 ees0mij1=fac3/ees0mij
14694                 fac3p=-3.0D0*fac3*rrmij
14695                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14696                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14697 !               ees0mij1=0.0D0
14698                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14699                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14700                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14701                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14702                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14703                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14704                 ecosap=ecosa1+ecosa2
14705                 ecosbp=ecosb1+ecosb2
14706                 ecosgp=ecosg1+ecosg2
14707                 ecosam=ecosa1-ecosa2
14708                 ecosbm=ecosb1-ecosb2
14709                 ecosgm=ecosg1-ecosg2
14710 ! Diagnostics
14711 !               ecosap=ecosa1
14712 !               ecosbp=ecosb1
14713 !               ecosgp=ecosg1
14714 !               ecosam=0.0D0
14715 !               ecosbm=0.0D0
14716 !               ecosgm=0.0D0
14717 ! End diagnostics
14718                 facont_hb(num_conti,i)=fcont
14719                 fprimcont=fprimcont/rij
14720 !d              facont_hb(num_conti,i)=1.0D0
14721 ! Following line is for diagnostics.
14722 !d              fprimcont=0.0D0
14723                 do k=1,3
14724                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14725                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14726                 enddo
14727                 do k=1,3
14728                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14729                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14730                 enddo
14731 !                gggp(1)=gggp(1)+ees0pijp*xj
14732 !                gggp(2)=gggp(2)+ees0pijp*yj
14733 !                gggp(3)=gggp(3)+ees0pijp*zj
14734 !                gggm(1)=gggm(1)+ees0mijp*xj
14735 !                gggm(2)=gggm(2)+ees0mijp*yj
14736 !                gggm(3)=gggm(3)+ees0mijp*zj
14737                 gggp(1)=gggp(1)+ees0pijp*xj &
14738                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14739                 gggp(2)=gggp(2)+ees0pijp*yj &
14740                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14741                 gggp(3)=gggp(3)+ees0pijp*zj &
14742                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14743
14744                 gggm(1)=gggm(1)+ees0mijp*xj &
14745                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14746
14747                 gggm(2)=gggm(2)+ees0mijp*yj &
14748                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14749
14750                 gggm(3)=gggm(3)+ees0mijp*zj &
14751                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14752
14753 ! Derivatives due to the contact function
14754                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14755                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14756                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14757                 do k=1,3
14758 !
14759 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14760 !          following the change of gradient-summation algorithm.
14761 !
14762 !grad                  ghalfp=0.5D0*gggp(k)
14763 !grad                  ghalfm=0.5D0*gggm(k)
14764 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14765 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14766 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14767 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14768 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14769 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14770 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14771 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14772 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14773 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14774 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14775 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14776 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14777 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14778                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14779                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14780                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14781                      *sss_ele_cut
14782
14783                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14784                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14785                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14786                      *sss_ele_cut
14787
14788                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14789                      *sss_ele_cut
14790
14791                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14792                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14793                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14794                      *sss_ele_cut
14795
14796                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14797                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14798                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14799                      *sss_ele_cut
14800
14801                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14802                      *sss_ele_cut
14803
14804                 enddo
14805               ENDIF ! wcorr
14806               endif  ! num_conti.le.maxconts
14807             endif  ! fcont.gt.0
14808           endif    ! j.gt.i+1
14809           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14810             do k=1,4
14811               do l=1,3
14812                 ghalf=0.5d0*agg(l,k)
14813                 aggi(l,k)=aggi(l,k)+ghalf
14814                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14815                 aggj(l,k)=aggj(l,k)+ghalf
14816               enddo
14817             enddo
14818             if (j.eq.nres-1 .and. i.lt.j-2) then
14819               do k=1,4
14820                 do l=1,3
14821                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14822                 enddo
14823               enddo
14824             endif
14825           endif
14826  128      continue
14827 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14828       return
14829       end subroutine eelecij_scale
14830 !-----------------------------------------------------------------------------
14831       subroutine evdwpp_short(evdw1)
14832 !
14833 ! Compute Evdwpp
14834 !
14835 !      implicit real*8 (a-h,o-z)
14836 !      include 'DIMENSIONS'
14837 !      include 'COMMON.CONTROL'
14838 !      include 'COMMON.IOUNITS'
14839 !      include 'COMMON.GEO'
14840 !      include 'COMMON.VAR'
14841 !      include 'COMMON.LOCAL'
14842 !      include 'COMMON.CHAIN'
14843 !      include 'COMMON.DERIV'
14844 !      include 'COMMON.INTERACT'
14845 !      include 'COMMON.CONTACTS'
14846 !      include 'COMMON.TORSION'
14847 !      include 'COMMON.VECTORS'
14848 !      include 'COMMON.FFIELD'
14849       real(kind=8),dimension(3) :: ggg
14850 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14851 #ifdef MOMENT
14852       real(kind=8) :: scal_el=1.0d0
14853 #else
14854       real(kind=8) :: scal_el=0.5d0
14855 #endif
14856 !el local variables
14857       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14858       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14859       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14860                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14861                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14862       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14863                     dist_temp, dist_init,sss_grad
14864       integer xshift,yshift,zshift
14865
14866
14867       evdw1=0.0D0
14868 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14869 !     & " iatel_e_vdw",iatel_e_vdw
14870       call flush(iout)
14871       do i=iatel_s_vdw,iatel_e_vdw
14872         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
14873         dxi=dc(1,i)
14874         dyi=dc(2,i)
14875         dzi=dc(3,i)
14876         dx_normi=dc_norm(1,i)
14877         dy_normi=dc_norm(2,i)
14878         dz_normi=dc_norm(3,i)
14879         xmedi=c(1,i)+0.5d0*dxi
14880         ymedi=c(2,i)+0.5d0*dyi
14881         zmedi=c(3,i)+0.5d0*dzi
14882           xmedi=dmod(xmedi,boxxsize)
14883           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14884           ymedi=dmod(ymedi,boxysize)
14885           if (ymedi.lt.0) ymedi=ymedi+boxysize
14886           zmedi=dmod(zmedi,boxzsize)
14887           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14888         num_conti=0
14889 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14890 !     &   ' ielend',ielend_vdw(i)
14891         call flush(iout)
14892         do j=ielstart_vdw(i),ielend_vdw(i)
14893           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14894 !el          ind=ind+1
14895           iteli=itel(i)
14896           itelj=itel(j)
14897           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14898           aaa=app(iteli,itelj)
14899           bbb=bpp(iteli,itelj)
14900           dxj=dc(1,j)
14901           dyj=dc(2,j)
14902           dzj=dc(3,j)
14903           dx_normj=dc_norm(1,j)
14904           dy_normj=dc_norm(2,j)
14905           dz_normj=dc_norm(3,j)
14906 !          xj=c(1,j)+0.5D0*dxj-xmedi
14907 !          yj=c(2,j)+0.5D0*dyj-ymedi
14908 !          zj=c(3,j)+0.5D0*dzj-zmedi
14909           xj=c(1,j)+0.5D0*dxj
14910           yj=c(2,j)+0.5D0*dyj
14911           zj=c(3,j)+0.5D0*dzj
14912           xj=mod(xj,boxxsize)
14913           if (xj.lt.0) xj=xj+boxxsize
14914           yj=mod(yj,boxysize)
14915           if (yj.lt.0) yj=yj+boxysize
14916           zj=mod(zj,boxzsize)
14917           if (zj.lt.0) zj=zj+boxzsize
14918       isubchap=0
14919       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14920       xj_safe=xj
14921       yj_safe=yj
14922       zj_safe=zj
14923       do xshift=-1,1
14924       do yshift=-1,1
14925       do zshift=-1,1
14926           xj=xj_safe+xshift*boxxsize
14927           yj=yj_safe+yshift*boxysize
14928           zj=zj_safe+zshift*boxzsize
14929           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14930           if(dist_temp.lt.dist_init) then
14931             dist_init=dist_temp
14932             xj_temp=xj
14933             yj_temp=yj
14934             zj_temp=zj
14935             isubchap=1
14936           endif
14937        enddo
14938        enddo
14939        enddo
14940        if (isubchap.eq.1) then
14941 !C          print *,i,j
14942           xj=xj_temp-xmedi
14943           yj=yj_temp-ymedi
14944           zj=zj_temp-zmedi
14945        else
14946           xj=xj_safe-xmedi
14947           yj=yj_safe-ymedi
14948           zj=zj_safe-zmedi
14949        endif
14950
14951           rij=xj*xj+yj*yj+zj*zj
14952           rrmij=1.0D0/rij
14953           rij=dsqrt(rij)
14954           sss=sscale(rij/rpp(iteli,itelj))
14955             sss_ele_cut=sscale_ele(rij)
14956             sss_ele_grad=sscagrad_ele(rij)
14957             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14958             if (sss_ele_cut.le.0.0) cycle
14959           if (sss.gt.0.0d0) then
14960             rmij=1.0D0/rij
14961             r3ij=rrmij*rmij
14962             r6ij=r3ij*r3ij
14963             ev1=aaa*r6ij*r6ij
14964 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14965             if (j.eq.i+2) ev1=scal_el*ev1
14966             ev2=bbb*r6ij
14967             evdwij=ev1+ev2
14968             if (energy_dec) then
14969               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14970             endif
14971             evdw1=evdw1+evdwij*sss*sss_ele_cut
14972 !
14973 ! Calculate contributions to the Cartesian gradient.
14974 !
14975             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
14976 !            ggg(1)=facvdw*xj
14977 !            ggg(2)=facvdw*yj
14978 !            ggg(3)=facvdw*zj
14979           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
14980           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14981           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
14982           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14983           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
14984           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14985
14986             do k=1,3
14987               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14988               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14989             enddo
14990           endif
14991         enddo ! j
14992       enddo   ! i
14993       return
14994       end subroutine evdwpp_short
14995 !-----------------------------------------------------------------------------
14996       subroutine escp_long(evdw2,evdw2_14)
14997 !
14998 ! This subroutine calculates the excluded-volume interaction energy between
14999 ! peptide-group centers and side chains and its gradient in virtual-bond and
15000 ! side-chain vectors.
15001 !
15002 !      implicit real*8 (a-h,o-z)
15003 !      include 'DIMENSIONS'
15004 !      include 'COMMON.GEO'
15005 !      include 'COMMON.VAR'
15006 !      include 'COMMON.LOCAL'
15007 !      include 'COMMON.CHAIN'
15008 !      include 'COMMON.DERIV'
15009 !      include 'COMMON.INTERACT'
15010 !      include 'COMMON.FFIELD'
15011 !      include 'COMMON.IOUNITS'
15012 !      include 'COMMON.CONTROL'
15013       real(kind=8),dimension(3) :: ggg
15014 !el local variables
15015       integer :: i,iint,j,k,iteli,itypj,subchap
15016       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15017       real(kind=8) :: evdw2,evdw2_14,evdwij
15018       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15019                     dist_temp, dist_init
15020
15021       evdw2=0.0D0
15022       evdw2_14=0.0d0
15023 !d    print '(a)','Enter ESCP'
15024 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15025       do i=iatscp_s,iatscp_e
15026         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15027         iteli=itel(i)
15028         xi=0.5D0*(c(1,i)+c(1,i+1))
15029         yi=0.5D0*(c(2,i)+c(2,i+1))
15030         zi=0.5D0*(c(3,i)+c(3,i+1))
15031           xi=mod(xi,boxxsize)
15032           if (xi.lt.0) xi=xi+boxxsize
15033           yi=mod(yi,boxysize)
15034           if (yi.lt.0) yi=yi+boxysize
15035           zi=mod(zi,boxzsize)
15036           if (zi.lt.0) zi=zi+boxzsize
15037
15038         do iint=1,nscp_gr(i)
15039
15040         do j=iscpstart(i,iint),iscpend(i,iint)
15041           itypj=itype(j,1)
15042           if (itypj.eq.ntyp1) cycle
15043 ! Uncomment following three lines for SC-p interactions
15044 !         xj=c(1,nres+j)-xi
15045 !         yj=c(2,nres+j)-yi
15046 !         zj=c(3,nres+j)-zi
15047 ! Uncomment following three lines for Ca-p interactions
15048           xj=c(1,j)
15049           yj=c(2,j)
15050           zj=c(3,j)
15051           xj=mod(xj,boxxsize)
15052           if (xj.lt.0) xj=xj+boxxsize
15053           yj=mod(yj,boxysize)
15054           if (yj.lt.0) yj=yj+boxysize
15055           zj=mod(zj,boxzsize)
15056           if (zj.lt.0) zj=zj+boxzsize
15057       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15058       xj_safe=xj
15059       yj_safe=yj
15060       zj_safe=zj
15061       subchap=0
15062       do xshift=-1,1
15063       do yshift=-1,1
15064       do zshift=-1,1
15065           xj=xj_safe+xshift*boxxsize
15066           yj=yj_safe+yshift*boxysize
15067           zj=zj_safe+zshift*boxzsize
15068           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15069           if(dist_temp.lt.dist_init) then
15070             dist_init=dist_temp
15071             xj_temp=xj
15072             yj_temp=yj
15073             zj_temp=zj
15074             subchap=1
15075           endif
15076        enddo
15077        enddo
15078        enddo
15079        if (subchap.eq.1) then
15080           xj=xj_temp-xi
15081           yj=yj_temp-yi
15082           zj=zj_temp-zi
15083        else
15084           xj=xj_safe-xi
15085           yj=yj_safe-yi
15086           zj=zj_safe-zi
15087        endif
15088           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15089
15090           rij=dsqrt(1.0d0/rrij)
15091             sss_ele_cut=sscale_ele(rij)
15092             sss_ele_grad=sscagrad_ele(rij)
15093 !            print *,sss_ele_cut,sss_ele_grad,&
15094 !            (rij),r_cut_ele,rlamb_ele
15095             if (sss_ele_cut.le.0.0) cycle
15096           sss=sscale((rij/rscp(itypj,iteli)))
15097           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15098           if (sss.lt.1.0d0) then
15099
15100             fac=rrij**expon2
15101             e1=fac*fac*aad(itypj,iteli)
15102             e2=fac*bad(itypj,iteli)
15103             if (iabs(j-i) .le. 2) then
15104               e1=scal14*e1
15105               e2=scal14*e2
15106               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15107             endif
15108             evdwij=e1+e2
15109             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15110             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15111                 'evdw2',i,j,sss,evdwij
15112 !
15113 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15114 !
15115             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15116             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15117             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15118             ggg(1)=xj*fac
15119             ggg(2)=yj*fac
15120             ggg(3)=zj*fac
15121 ! Uncomment following three lines for SC-p interactions
15122 !           do k=1,3
15123 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15124 !           enddo
15125 ! Uncomment following line for SC-p interactions
15126 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15127             do k=1,3
15128               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15129               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15130             enddo
15131           endif
15132         enddo
15133
15134         enddo ! iint
15135       enddo ! i
15136       do i=1,nct
15137         do j=1,3
15138           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15139           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15140           gradx_scp(j,i)=expon*gradx_scp(j,i)
15141         enddo
15142       enddo
15143 !******************************************************************************
15144 !
15145 !                              N O T E !!!
15146 !
15147 ! To save time the factor EXPON has been extracted from ALL components
15148 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15149 ! use!
15150 !
15151 !******************************************************************************
15152       return
15153       end subroutine escp_long
15154 !-----------------------------------------------------------------------------
15155       subroutine escp_short(evdw2,evdw2_14)
15156 !
15157 ! This subroutine calculates the excluded-volume interaction energy between
15158 ! peptide-group centers and side chains and its gradient in virtual-bond and
15159 ! side-chain vectors.
15160 !
15161 !      implicit real*8 (a-h,o-z)
15162 !      include 'DIMENSIONS'
15163 !      include 'COMMON.GEO'
15164 !      include 'COMMON.VAR'
15165 !      include 'COMMON.LOCAL'
15166 !      include 'COMMON.CHAIN'
15167 !      include 'COMMON.DERIV'
15168 !      include 'COMMON.INTERACT'
15169 !      include 'COMMON.FFIELD'
15170 !      include 'COMMON.IOUNITS'
15171 !      include 'COMMON.CONTROL'
15172       real(kind=8),dimension(3) :: ggg
15173 !el local variables
15174       integer :: i,iint,j,k,iteli,itypj,subchap
15175       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15176       real(kind=8) :: evdw2,evdw2_14,evdwij
15177       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15178                     dist_temp, dist_init
15179
15180       evdw2=0.0D0
15181       evdw2_14=0.0d0
15182 !d    print '(a)','Enter ESCP'
15183 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15184       do i=iatscp_s,iatscp_e
15185         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15186         iteli=itel(i)
15187         xi=0.5D0*(c(1,i)+c(1,i+1))
15188         yi=0.5D0*(c(2,i)+c(2,i+1))
15189         zi=0.5D0*(c(3,i)+c(3,i+1))
15190           xi=mod(xi,boxxsize)
15191           if (xi.lt.0) xi=xi+boxxsize
15192           yi=mod(yi,boxysize)
15193           if (yi.lt.0) yi=yi+boxysize
15194           zi=mod(zi,boxzsize)
15195           if (zi.lt.0) zi=zi+boxzsize
15196
15197         do iint=1,nscp_gr(i)
15198
15199         do j=iscpstart(i,iint),iscpend(i,iint)
15200           itypj=itype(j,1)
15201           if (itypj.eq.ntyp1) cycle
15202 ! Uncomment following three lines for SC-p interactions
15203 !         xj=c(1,nres+j)-xi
15204 !         yj=c(2,nres+j)-yi
15205 !         zj=c(3,nres+j)-zi
15206 ! Uncomment following three lines for Ca-p interactions
15207 !          xj=c(1,j)-xi
15208 !          yj=c(2,j)-yi
15209 !          zj=c(3,j)-zi
15210           xj=c(1,j)
15211           yj=c(2,j)
15212           zj=c(3,j)
15213           xj=mod(xj,boxxsize)
15214           if (xj.lt.0) xj=xj+boxxsize
15215           yj=mod(yj,boxysize)
15216           if (yj.lt.0) yj=yj+boxysize
15217           zj=mod(zj,boxzsize)
15218           if (zj.lt.0) zj=zj+boxzsize
15219       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15220       xj_safe=xj
15221       yj_safe=yj
15222       zj_safe=zj
15223       subchap=0
15224       do xshift=-1,1
15225       do yshift=-1,1
15226       do zshift=-1,1
15227           xj=xj_safe+xshift*boxxsize
15228           yj=yj_safe+yshift*boxysize
15229           zj=zj_safe+zshift*boxzsize
15230           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15231           if(dist_temp.lt.dist_init) then
15232             dist_init=dist_temp
15233             xj_temp=xj
15234             yj_temp=yj
15235             zj_temp=zj
15236             subchap=1
15237           endif
15238        enddo
15239        enddo
15240        enddo
15241        if (subchap.eq.1) then
15242           xj=xj_temp-xi
15243           yj=yj_temp-yi
15244           zj=zj_temp-zi
15245        else
15246           xj=xj_safe-xi
15247           yj=yj_safe-yi
15248           zj=zj_safe-zi
15249        endif
15250
15251           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15252           rij=dsqrt(1.0d0/rrij)
15253             sss_ele_cut=sscale_ele(rij)
15254             sss_ele_grad=sscagrad_ele(rij)
15255 !            print *,sss_ele_cut,sss_ele_grad,&
15256 !            (rij),r_cut_ele,rlamb_ele
15257             if (sss_ele_cut.le.0.0) cycle
15258           sss=sscale(rij/rscp(itypj,iteli))
15259           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15260           if (sss.gt.0.0d0) then
15261
15262             fac=rrij**expon2
15263             e1=fac*fac*aad(itypj,iteli)
15264             e2=fac*bad(itypj,iteli)
15265             if (iabs(j-i) .le. 2) then
15266               e1=scal14*e1
15267               e2=scal14*e2
15268               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15269             endif
15270             evdwij=e1+e2
15271             evdw2=evdw2+evdwij*sss*sss_ele_cut
15272             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15273                 'evdw2',i,j,sss,evdwij
15274 !
15275 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15276 !
15277             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15278             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15279             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15280
15281             ggg(1)=xj*fac
15282             ggg(2)=yj*fac
15283             ggg(3)=zj*fac
15284 ! Uncomment following three lines for SC-p interactions
15285 !           do k=1,3
15286 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15287 !           enddo
15288 ! Uncomment following line for SC-p interactions
15289 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15290             do k=1,3
15291               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15292               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15293             enddo
15294           endif
15295         enddo
15296
15297         enddo ! iint
15298       enddo ! i
15299       do i=1,nct
15300         do j=1,3
15301           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15302           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15303           gradx_scp(j,i)=expon*gradx_scp(j,i)
15304         enddo
15305       enddo
15306 !******************************************************************************
15307 !
15308 !                              N O T E !!!
15309 !
15310 ! To save time the factor EXPON has been extracted from ALL components
15311 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15312 ! use!
15313 !
15314 !******************************************************************************
15315       return
15316       end subroutine escp_short
15317 !-----------------------------------------------------------------------------
15318 ! energy_p_new-sep_barrier.F
15319 !-----------------------------------------------------------------------------
15320       subroutine sc_grad_scale(scalfac)
15321 !      implicit real*8 (a-h,o-z)
15322       use calc_data
15323 !      include 'DIMENSIONS'
15324 !      include 'COMMON.CHAIN'
15325 !      include 'COMMON.DERIV'
15326 !      include 'COMMON.CALC'
15327 !      include 'COMMON.IOUNITS'
15328       real(kind=8),dimension(3) :: dcosom1,dcosom2
15329       real(kind=8) :: scalfac
15330 !el local variables
15331 !      integer :: i,j,k,l
15332
15333       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15334       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15335       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15336            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15337 ! diagnostics only
15338 !      eom1=0.0d0
15339 !      eom2=0.0d0
15340 !      eom12=evdwij*eps1_om12
15341 ! end diagnostics
15342 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15343 !     &  " sigder",sigder
15344 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15345 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15346       do k=1,3
15347         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15348         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15349       enddo
15350       do k=1,3
15351         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15352          *sss_ele_cut
15353       enddo
15354 !      write (iout,*) "gg",(gg(k),k=1,3)
15355       do k=1,3
15356         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15357                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15358                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15359                  *sss_ele_cut
15360         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15361                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15362                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15363          *sss_ele_cut
15364 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15365 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15366 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15367 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15368       enddo
15369 !
15370 ! Calculate the components of the gradient in DC and X
15371 !
15372       do l=1,3
15373         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15374         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15375       enddo
15376       return
15377       end subroutine sc_grad_scale
15378 !-----------------------------------------------------------------------------
15379 ! energy_split-sep.F
15380 !-----------------------------------------------------------------------------
15381       subroutine etotal_long(energia)
15382 !
15383 ! Compute the long-range slow-varying contributions to the energy
15384 !
15385 !      implicit real*8 (a-h,o-z)
15386 !      include 'DIMENSIONS'
15387       use MD_data, only: totT,usampl,eq_time
15388 #ifndef ISNAN
15389       external proc_proc
15390 #ifdef WINPGI
15391 !MS$ATTRIBUTES C ::  proc_proc
15392 #endif
15393 #endif
15394 #ifdef MPI
15395       include "mpif.h"
15396       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15397 #endif
15398 !      include 'COMMON.SETUP'
15399 !      include 'COMMON.IOUNITS'
15400 !      include 'COMMON.FFIELD'
15401 !      include 'COMMON.DERIV'
15402 !      include 'COMMON.INTERACT'
15403 !      include 'COMMON.SBRIDGE'
15404 !      include 'COMMON.CHAIN'
15405 !      include 'COMMON.VAR'
15406 !      include 'COMMON.LOCAL'
15407 !      include 'COMMON.MD'
15408       real(kind=8),dimension(0:n_ene) :: energia
15409 !el local variables
15410       integer :: i,n_corr,n_corr1,ierror,ierr
15411       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15412                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15413                   ecorr,ecorr5,ecorr6,eturn6,time00
15414 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15415 !elwrite(iout,*)"in etotal long"
15416
15417       if (modecalc.eq.12.or.modecalc.eq.14) then
15418 #ifdef MPI
15419 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15420 #else
15421         call int_from_cart1(.false.)
15422 #endif
15423       endif
15424 !elwrite(iout,*)"in etotal long"
15425
15426 #ifdef MPI
15427 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15428 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15429       call flush(iout)
15430       if (nfgtasks.gt.1) then
15431         time00=MPI_Wtime()
15432 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15433         if (fg_rank.eq.0) then
15434           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15435 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15436 !          call flush(iout)
15437 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15438 ! FG slaves as WEIGHTS array.
15439           weights_(1)=wsc
15440           weights_(2)=wscp
15441           weights_(3)=welec
15442           weights_(4)=wcorr
15443           weights_(5)=wcorr5
15444           weights_(6)=wcorr6
15445           weights_(7)=wel_loc
15446           weights_(8)=wturn3
15447           weights_(9)=wturn4
15448           weights_(10)=wturn6
15449           weights_(11)=wang
15450           weights_(12)=wscloc
15451           weights_(13)=wtor
15452           weights_(14)=wtor_d
15453           weights_(15)=wstrain
15454           weights_(16)=wvdwpp
15455           weights_(17)=wbond
15456           weights_(18)=scal14
15457           weights_(21)=wsccor
15458 ! FG Master broadcasts the WEIGHTS_ array
15459           call MPI_Bcast(weights_(1),n_ene,&
15460               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15461         else
15462 ! FG slaves receive the WEIGHTS array
15463           call MPI_Bcast(weights(1),n_ene,&
15464               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15465           wsc=weights(1)
15466           wscp=weights(2)
15467           welec=weights(3)
15468           wcorr=weights(4)
15469           wcorr5=weights(5)
15470           wcorr6=weights(6)
15471           wel_loc=weights(7)
15472           wturn3=weights(8)
15473           wturn4=weights(9)
15474           wturn6=weights(10)
15475           wang=weights(11)
15476           wscloc=weights(12)
15477           wtor=weights(13)
15478           wtor_d=weights(14)
15479           wstrain=weights(15)
15480           wvdwpp=weights(16)
15481           wbond=weights(17)
15482           scal14=weights(18)
15483           wsccor=weights(21)
15484         endif
15485         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15486           king,FG_COMM,IERR)
15487          time_Bcast=time_Bcast+MPI_Wtime()-time00
15488          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15489 !        call chainbuild_cart
15490 !        call int_from_cart1(.false.)
15491       endif
15492 !      write (iout,*) 'Processor',myrank,
15493 !     &  ' calling etotal_short ipot=',ipot
15494 !      call flush(iout)
15495 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15496 #endif
15497 !d    print *,'nnt=',nnt,' nct=',nct
15498 !
15499 !elwrite(iout,*)"in etotal long"
15500 ! Compute the side-chain and electrostatic interaction energy
15501 !
15502       goto (101,102,103,104,105,106) ipot
15503 ! Lennard-Jones potential.
15504   101 call elj_long(evdw)
15505 !d    print '(a)','Exit ELJ'
15506       goto 107
15507 ! Lennard-Jones-Kihara potential (shifted).
15508   102 call eljk_long(evdw)
15509       goto 107
15510 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15511   103 call ebp_long(evdw)
15512       goto 107
15513 ! Gay-Berne potential (shifted LJ, angular dependence).
15514   104 call egb_long(evdw)
15515       goto 107
15516 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15517   105 call egbv_long(evdw)
15518       goto 107
15519 ! Soft-sphere potential
15520   106 call e_softsphere(evdw)
15521 !
15522 ! Calculate electrostatic (H-bonding) energy of the main chain.
15523 !
15524   107 continue
15525       call vec_and_deriv
15526       if (ipot.lt.6) then
15527 #ifdef SPLITELE
15528          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15529              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15530              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15531              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15532 #else
15533          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15534              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15535              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15536              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15537 #endif
15538            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15539          else
15540             ees=0
15541             evdw1=0
15542             eel_loc=0
15543             eello_turn3=0
15544             eello_turn4=0
15545          endif
15546       else
15547 !        write (iout,*) "Soft-spheer ELEC potential"
15548         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15549          eello_turn4)
15550       endif
15551 !
15552 ! Calculate excluded-volume interaction energy between peptide groups
15553 ! and side chains.
15554 !
15555       if (ipot.lt.6) then
15556        if(wscp.gt.0d0) then
15557         call escp_long(evdw2,evdw2_14)
15558        else
15559         evdw2=0
15560         evdw2_14=0
15561        endif
15562       else
15563         call escp_soft_sphere(evdw2,evdw2_14)
15564       endif
15565 !
15566 ! 12/1/95 Multi-body terms
15567 !
15568       n_corr=0
15569       n_corr1=0
15570       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15571           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15572          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15573 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15574 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15575       else
15576          ecorr=0.0d0
15577          ecorr5=0.0d0
15578          ecorr6=0.0d0
15579          eturn6=0.0d0
15580       endif
15581       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15582          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15583       endif
15584 !
15585 ! If performing constraint dynamics, call the constraint energy
15586 !  after the equilibration time
15587       if(usampl.and.totT.gt.eq_time) then
15588          call EconstrQ
15589          call Econstr_back
15590       else
15591          Uconst=0.0d0
15592          Uconst_back=0.0d0
15593       endif
15594 !
15595 ! Sum the energies
15596 !
15597       do i=1,n_ene
15598         energia(i)=0.0d0
15599       enddo
15600       energia(1)=evdw
15601 #ifdef SCP14
15602       energia(2)=evdw2-evdw2_14
15603       energia(18)=evdw2_14
15604 #else
15605       energia(2)=evdw2
15606       energia(18)=0.0d0
15607 #endif
15608 #ifdef SPLITELE
15609       energia(3)=ees
15610       energia(16)=evdw1
15611 #else
15612       energia(3)=ees+evdw1
15613       energia(16)=0.0d0
15614 #endif
15615       energia(4)=ecorr
15616       energia(5)=ecorr5
15617       energia(6)=ecorr6
15618       energia(7)=eel_loc
15619       energia(8)=eello_turn3
15620       energia(9)=eello_turn4
15621       energia(10)=eturn6
15622       energia(20)=Uconst+Uconst_back
15623       call sum_energy(energia,.true.)
15624 !      write (iout,*) "Exit ETOTAL_LONG"
15625       call flush(iout)
15626       return
15627       end subroutine etotal_long
15628 !-----------------------------------------------------------------------------
15629       subroutine etotal_short(energia)
15630 !
15631 ! Compute the short-range fast-varying contributions to the energy
15632 !
15633 !      implicit real*8 (a-h,o-z)
15634 !      include 'DIMENSIONS'
15635 #ifndef ISNAN
15636       external proc_proc
15637 #ifdef WINPGI
15638 !MS$ATTRIBUTES C ::  proc_proc
15639 #endif
15640 #endif
15641 #ifdef MPI
15642       include "mpif.h"
15643       integer :: ierror,ierr
15644       real(kind=8),dimension(n_ene) :: weights_
15645       real(kind=8) :: time00
15646 #endif
15647 !      include 'COMMON.SETUP'
15648 !      include 'COMMON.IOUNITS'
15649 !      include 'COMMON.FFIELD'
15650 !      include 'COMMON.DERIV'
15651 !      include 'COMMON.INTERACT'
15652 !      include 'COMMON.SBRIDGE'
15653 !      include 'COMMON.CHAIN'
15654 !      include 'COMMON.VAR'
15655 !      include 'COMMON.LOCAL'
15656       real(kind=8),dimension(0:n_ene) :: energia
15657 !el local variables
15658       integer :: i,nres6
15659       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15660       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15661       nres6=6*nres
15662
15663 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15664 !      call flush(iout)
15665       if (modecalc.eq.12.or.modecalc.eq.14) then
15666 #ifdef MPI
15667         if (fg_rank.eq.0) call int_from_cart1(.false.)
15668 #else
15669         call int_from_cart1(.false.)
15670 #endif
15671       endif
15672 #ifdef MPI
15673 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15674 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15675 !      call flush(iout)
15676       if (nfgtasks.gt.1) then
15677         time00=MPI_Wtime()
15678 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15679         if (fg_rank.eq.0) then
15680           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15681 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15682 !          call flush(iout)
15683 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15684 ! FG slaves as WEIGHTS array.
15685           weights_(1)=wsc
15686           weights_(2)=wscp
15687           weights_(3)=welec
15688           weights_(4)=wcorr
15689           weights_(5)=wcorr5
15690           weights_(6)=wcorr6
15691           weights_(7)=wel_loc
15692           weights_(8)=wturn3
15693           weights_(9)=wturn4
15694           weights_(10)=wturn6
15695           weights_(11)=wang
15696           weights_(12)=wscloc
15697           weights_(13)=wtor
15698           weights_(14)=wtor_d
15699           weights_(15)=wstrain
15700           weights_(16)=wvdwpp
15701           weights_(17)=wbond
15702           weights_(18)=scal14
15703           weights_(21)=wsccor
15704 ! FG Master broadcasts the WEIGHTS_ array
15705           call MPI_Bcast(weights_(1),n_ene,&
15706               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15707         else
15708 ! FG slaves receive the WEIGHTS array
15709           call MPI_Bcast(weights(1),n_ene,&
15710               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15711           wsc=weights(1)
15712           wscp=weights(2)
15713           welec=weights(3)
15714           wcorr=weights(4)
15715           wcorr5=weights(5)
15716           wcorr6=weights(6)
15717           wel_loc=weights(7)
15718           wturn3=weights(8)
15719           wturn4=weights(9)
15720           wturn6=weights(10)
15721           wang=weights(11)
15722           wscloc=weights(12)
15723           wtor=weights(13)
15724           wtor_d=weights(14)
15725           wstrain=weights(15)
15726           wvdwpp=weights(16)
15727           wbond=weights(17)
15728           scal14=weights(18)
15729           wsccor=weights(21)
15730         endif
15731 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15732         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15733           king,FG_COMM,IERR)
15734 !        write (iout,*) "Processor",myrank," BROADCAST c"
15735         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15736           king,FG_COMM,IERR)
15737 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15738         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15739           king,FG_COMM,IERR)
15740 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15741         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15742           king,FG_COMM,IERR)
15743 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15744         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15745           king,FG_COMM,IERR)
15746 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15747         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15748           king,FG_COMM,IERR)
15749 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15750         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15751           king,FG_COMM,IERR)
15752 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15753         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15754           king,FG_COMM,IERR)
15755 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15756         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15757           king,FG_COMM,IERR)
15758          time_Bcast=time_Bcast+MPI_Wtime()-time00
15759 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15760       endif
15761 !      write (iout,*) 'Processor',myrank,
15762 !     &  ' calling etotal_short ipot=',ipot
15763 !      call flush(iout)
15764 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15765 #endif
15766 !      call int_from_cart1(.false.)
15767 !
15768 ! Compute the side-chain and electrostatic interaction energy
15769 !
15770       goto (101,102,103,104,105,106) ipot
15771 ! Lennard-Jones potential.
15772   101 call elj_short(evdw)
15773 !d    print '(a)','Exit ELJ'
15774       goto 107
15775 ! Lennard-Jones-Kihara potential (shifted).
15776   102 call eljk_short(evdw)
15777       goto 107
15778 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15779   103 call ebp_short(evdw)
15780       goto 107
15781 ! Gay-Berne potential (shifted LJ, angular dependence).
15782   104 call egb_short(evdw)
15783       goto 107
15784 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15785   105 call egbv_short(evdw)
15786       goto 107
15787 ! Soft-sphere potential - already dealt with in the long-range part
15788   106 evdw=0.0d0
15789 !  106 call e_softsphere_short(evdw)
15790 !
15791 ! Calculate electrostatic (H-bonding) energy of the main chain.
15792 !
15793   107 continue
15794 !
15795 ! Calculate the short-range part of Evdwpp
15796 !
15797       call evdwpp_short(evdw1)
15798 !
15799 ! Calculate the short-range part of ESCp
15800 !
15801       if (ipot.lt.6) then
15802         call escp_short(evdw2,evdw2_14)
15803       endif
15804 !
15805 ! Calculate the bond-stretching energy
15806 !
15807       call ebond(estr)
15808 !
15809 ! Calculate the disulfide-bridge and other energy and the contributions
15810 ! from other distance constraints.
15811       call edis(ehpb)
15812 !
15813 ! Calculate the virtual-bond-angle energy.
15814 !
15815       call ebend(ebe,ethetacnstr)
15816 !
15817 ! Calculate the SC local energy.
15818 !
15819       call vec_and_deriv
15820       call esc(escloc)
15821 !
15822 ! Calculate the virtual-bond torsional energy.
15823 !
15824       call etor(etors,edihcnstr)
15825 !
15826 ! 6/23/01 Calculate double-torsional energy
15827 !
15828       call etor_d(etors_d)
15829 !
15830 ! 21/5/07 Calculate local sicdechain correlation energy
15831 !
15832       if (wsccor.gt.0.0d0) then
15833         call eback_sc_corr(esccor)
15834       else
15835         esccor=0.0d0
15836       endif
15837 !
15838 ! Put energy components into an array
15839 !
15840       do i=1,n_ene
15841         energia(i)=0.0d0
15842       enddo
15843       energia(1)=evdw
15844 #ifdef SCP14
15845       energia(2)=evdw2-evdw2_14
15846       energia(18)=evdw2_14
15847 #else
15848       energia(2)=evdw2
15849       energia(18)=0.0d0
15850 #endif
15851 #ifdef SPLITELE
15852       energia(16)=evdw1
15853 #else
15854       energia(3)=evdw1
15855 #endif
15856       energia(11)=ebe
15857       energia(12)=escloc
15858       energia(13)=etors
15859       energia(14)=etors_d
15860       energia(15)=ehpb
15861       energia(17)=estr
15862       energia(19)=edihcnstr
15863       energia(21)=esccor
15864 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15865       call flush(iout)
15866       call sum_energy(energia,.true.)
15867 !      write (iout,*) "Exit ETOTAL_SHORT"
15868       call flush(iout)
15869       return
15870       end subroutine etotal_short
15871 !-----------------------------------------------------------------------------
15872 ! gnmr1.f
15873 !-----------------------------------------------------------------------------
15874       real(kind=8) function gnmr1(y,ymin,ymax)
15875 !      implicit none
15876       real(kind=8) :: y,ymin,ymax
15877       real(kind=8) :: wykl=4.0d0
15878       if (y.lt.ymin) then
15879         gnmr1=(ymin-y)**wykl/wykl
15880       else if (y.gt.ymax) then
15881         gnmr1=(y-ymax)**wykl/wykl
15882       else
15883         gnmr1=0.0d0
15884       endif
15885       return
15886       end function gnmr1
15887 !-----------------------------------------------------------------------------
15888       real(kind=8) function gnmr1prim(y,ymin,ymax)
15889 !      implicit none
15890       real(kind=8) :: y,ymin,ymax
15891       real(kind=8) :: wykl=4.0d0
15892       if (y.lt.ymin) then
15893         gnmr1prim=-(ymin-y)**(wykl-1)
15894       else if (y.gt.ymax) then
15895         gnmr1prim=(y-ymax)**(wykl-1)
15896       else
15897         gnmr1prim=0.0d0
15898       endif
15899       return
15900       end function gnmr1prim
15901 !----------------------------------------------------------------------------
15902       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
15903       real(kind=8) y,ymin,ymax,sigma
15904       real(kind=8) wykl /4.0d0/
15905       if (y.lt.ymin) then
15906         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
15907       else if (y.gt.ymax) then
15908         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
15909       else
15910         rlornmr1=0.0d0
15911       endif
15912       return
15913       end function rlornmr1
15914 !------------------------------------------------------------------------------
15915       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
15916       real(kind=8) y,ymin,ymax,sigma
15917       real(kind=8) wykl /4.0d0/
15918       if (y.lt.ymin) then
15919         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
15920         ((ymin-y)**wykl+sigma**wykl)**2
15921       else if (y.gt.ymax) then
15922         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
15923         ((y-ymax)**wykl+sigma**wykl)**2
15924       else
15925         rlornmr1prim=0.0d0
15926       endif
15927       return
15928       end function rlornmr1prim
15929
15930       real(kind=8) function harmonic(y,ymax)
15931 !      implicit none
15932       real(kind=8) :: y,ymax
15933       real(kind=8) :: wykl=2.0d0
15934       harmonic=(y-ymax)**wykl
15935       return
15936       end function harmonic
15937 !-----------------------------------------------------------------------------
15938       real(kind=8) function harmonicprim(y,ymax)
15939       real(kind=8) :: y,ymin,ymax
15940       real(kind=8) :: wykl=2.0d0
15941       harmonicprim=(y-ymax)*wykl
15942       return
15943       end function harmonicprim
15944 !-----------------------------------------------------------------------------
15945 ! gradient_p.F
15946 !-----------------------------------------------------------------------------
15947       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
15948
15949       use io_base, only:intout,briefout
15950 !      implicit real*8 (a-h,o-z)
15951 !      include 'DIMENSIONS'
15952 !      include 'COMMON.CHAIN'
15953 !      include 'COMMON.DERIV'
15954 !      include 'COMMON.VAR'
15955 !      include 'COMMON.INTERACT'
15956 !      include 'COMMON.FFIELD'
15957 !      include 'COMMON.MD'
15958 !      include 'COMMON.IOUNITS'
15959       real(kind=8),external :: ufparm
15960       integer :: uiparm(1)
15961       real(kind=8) :: urparm(1)
15962       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
15963       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
15964       integer :: n,nf,ind,ind1,i,k,j
15965 !
15966 ! This subroutine calculates total internal coordinate gradient.
15967 ! Depending on the number of function evaluations, either whole energy
15968 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
15969 ! internal coordinates are reevaluated or only the cartesian-in-internal
15970 ! coordinate derivatives are evaluated. The subroutine was designed to work
15971 ! with SUMSL.
15972 !
15973 !
15974       icg=mod(nf,2)+1
15975
15976 !d      print *,'grad',nf,icg
15977       if (nf-nfl+1) 20,30,40
15978    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
15979 !    write (iout,*) 'grad 20'
15980       if (nf.eq.0) return
15981       goto 40
15982    30 call var_to_geom(n,x)
15983       call chainbuild
15984 !    write (iout,*) 'grad 30'
15985 !
15986 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
15987 !
15988    40 call cartder
15989 !     write (iout,*) 'grad 40'
15990 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
15991 !
15992 ! Convert the Cartesian gradient into internal-coordinate gradient.
15993 !
15994       ind=0
15995       ind1=0
15996       do i=1,nres-2
15997       gthetai=0.0D0
15998       gphii=0.0D0
15999       do j=i+1,nres-1
16000           ind=ind+1
16001 !         ind=indmat(i,j)
16002 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16003         do k=1,3
16004             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16005           enddo
16006         do k=1,3
16007           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16008           enddo
16009         enddo
16010       do j=i+1,nres-1
16011           ind1=ind1+1
16012 !         ind1=indmat(i,j)
16013 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16014         do k=1,3
16015           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16016           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16017           enddo
16018         enddo
16019       if (i.gt.1) g(i-1)=gphii
16020       if (n.gt.nphi) g(nphi+i)=gthetai
16021       enddo
16022       if (n.le.nphi+ntheta) goto 10
16023       do i=2,nres-1
16024       if (itype(i,1).ne.10) then
16025           galphai=0.0D0
16026         gomegai=0.0D0
16027         do k=1,3
16028           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16029           enddo
16030         do k=1,3
16031           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16032           enddo
16033           g(ialph(i,1))=galphai
16034         g(ialph(i,1)+nside)=gomegai
16035         endif
16036       enddo
16037 !
16038 ! Add the components corresponding to local energy terms.
16039 !
16040    10 continue
16041       do i=1,nvar
16042 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16043         g(i)=g(i)+gloc(i,icg)
16044       enddo
16045 ! Uncomment following three lines for diagnostics.
16046 !d    call intout
16047 !elwrite(iout,*) "in gradient after calling intout"
16048 !d    call briefout(0,0.0d0)
16049 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16050       return
16051       end subroutine gradient
16052 !-----------------------------------------------------------------------------
16053       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16054
16055       use comm_chu
16056 !      implicit real*8 (a-h,o-z)
16057 !      include 'DIMENSIONS'
16058 !      include 'COMMON.DERIV'
16059 !      include 'COMMON.IOUNITS'
16060 !      include 'COMMON.GEO'
16061       integer :: n,nf
16062 !el      integer :: jjj
16063 !el      common /chuju/ jjj
16064       real(kind=8) :: energia(0:n_ene)
16065       integer :: uiparm(1)
16066       real(kind=8) :: urparm(1)
16067       real(kind=8) :: f
16068       real(kind=8),external :: ufparm
16069       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16070 !     if (jjj.gt.0) then
16071 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16072 !     endif
16073       nfl=nf
16074       icg=mod(nf,2)+1
16075 !d      print *,'func',nf,nfl,icg
16076       call var_to_geom(n,x)
16077       call zerograd
16078       call chainbuild
16079 !d    write (iout,*) 'ETOTAL called from FUNC'
16080       call etotal(energia)
16081       call sum_gradient
16082       f=energia(0)
16083 !     if (jjj.gt.0) then
16084 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16085 !       write (iout,*) 'f=',etot
16086 !       jjj=0
16087 !     endif
16088       return
16089       end subroutine func
16090 !-----------------------------------------------------------------------------
16091       subroutine cartgrad
16092 !      implicit real*8 (a-h,o-z)
16093 !      include 'DIMENSIONS'
16094       use energy_data
16095       use MD_data, only: totT,usampl,eq_time
16096 #ifdef MPI
16097       include 'mpif.h'
16098 #endif
16099 !      include 'COMMON.CHAIN'
16100 !      include 'COMMON.DERIV'
16101 !      include 'COMMON.VAR'
16102 !      include 'COMMON.INTERACT'
16103 !      include 'COMMON.FFIELD'
16104 !      include 'COMMON.MD'
16105 !      include 'COMMON.IOUNITS'
16106 !      include 'COMMON.TIME1'
16107 !
16108       integer :: i,j
16109
16110 ! This subrouting calculates total Cartesian coordinate gradient.
16111 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16112 !
16113 !el#define DEBUG
16114 #ifdef TIMING
16115       time00=MPI_Wtime()
16116 #endif
16117       icg=1
16118       call sum_gradient
16119 #ifdef TIMING
16120 #endif
16121 !el      write (iout,*) "After sum_gradient"
16122 #ifdef DEBUG
16123 !el      write (iout,*) "After sum_gradient"
16124       do i=1,nres-1
16125         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16126         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16127       enddo
16128 #endif
16129 ! If performing constraint dynamics, add the gradients of the constraint energy
16130       if(usampl.and.totT.gt.eq_time) then
16131          do i=1,nct
16132            do j=1,3
16133              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16134              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16135            enddo
16136          enddo
16137          do i=1,nres-3
16138            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16139          enddo
16140          do i=1,nres-2
16141            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16142          enddo
16143       endif
16144 !elwrite (iout,*) "After sum_gradient"
16145 #ifdef TIMING
16146       time01=MPI_Wtime()
16147 #endif
16148       call intcartderiv
16149 !elwrite (iout,*) "After sum_gradient"
16150 #ifdef TIMING
16151       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16152 #endif
16153 !     call checkintcartgrad
16154 !     write(iout,*) 'calling int_to_cart'
16155 #ifdef DEBUG
16156       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16157 #endif
16158       do i=0,nct
16159         do j=1,3
16160           gcart(j,i)=gradc(j,i,icg)
16161           gxcart(j,i)=gradx(j,i,icg)
16162 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16163         enddo
16164 #ifdef DEBUG
16165         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16166           (gxcart(j,i),j=1,3),gloc(i,icg)
16167 #endif
16168       enddo
16169 #ifdef TIMING
16170       time01=MPI_Wtime()
16171 #endif
16172        print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16173       call int_to_cart
16174              print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16175
16176 #ifdef TIMING
16177             time_inttocart=time_inttocart+MPI_Wtime()-time01
16178 #endif
16179 #ifdef DEBUG
16180             write (iout,*) "gcart and gxcart after int_to_cart"
16181             do i=0,nres-1
16182             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16183                 (gxcart(j,i),j=1,3)
16184             enddo
16185 #endif
16186 #ifdef CARGRAD
16187 #ifdef DEBUG
16188             write (iout,*) "CARGRAD"
16189 #endif
16190             do i=nres,0,-1
16191             do j=1,3
16192               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16193       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16194             enddo
16195       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16196       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16197             enddo
16198       ! Correction: dummy residues
16199             if (nnt.gt.1) then
16200               do j=1,3
16201       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16202                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16203               enddo
16204             endif
16205             if (nct.lt.nres) then
16206               do j=1,3
16207       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16208                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16209               enddo
16210             endif
16211 #endif
16212 #ifdef TIMING
16213             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16214 #endif
16215       !el#undef DEBUG
16216             return
16217             end subroutine cartgrad
16218       !-----------------------------------------------------------------------------
16219             subroutine zerograd
16220       !      implicit real*8 (a-h,o-z)
16221       !      include 'DIMENSIONS'
16222       !      include 'COMMON.DERIV'
16223       !      include 'COMMON.CHAIN'
16224       !      include 'COMMON.VAR'
16225       !      include 'COMMON.MD'
16226       !      include 'COMMON.SCCOR'
16227       !
16228       !el local variables
16229             integer :: i,j,intertyp,k
16230       ! Initialize Cartesian-coordinate gradient
16231       !
16232       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16233       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16234
16235       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16236       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16237       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16238       !      allocate(gradcorr_long(3,nres))
16239       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16240       !      allocate(gcorr6_turn_long(3,nres))
16241       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16242
16243       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16244
16245       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16246       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16247
16248       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16249       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16250
16251       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16252       !      allocate(gscloc(3,nres)) !(3,maxres)
16253       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16254
16255
16256
16257       !      common /deriv_scloc/
16258       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16259       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16260       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16261       !      common /mpgrad/
16262       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16263
16264
16265
16266       !          gradc(j,i,icg)=0.0d0
16267       !          gradx(j,i,icg)=0.0d0
16268
16269       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16270       !elwrite(iout,*) "icg",icg
16271             do i=-1,nres
16272             do j=1,3
16273               gvdwx(j,i)=0.0D0
16274               gradx_scp(j,i)=0.0D0
16275               gvdwc(j,i)=0.0D0
16276               gvdwc_scp(j,i)=0.0D0
16277               gvdwc_scpp(j,i)=0.0d0
16278               gelc(j,i)=0.0D0
16279               gelc_long(j,i)=0.0D0
16280               gradb(j,i)=0.0d0
16281               gradbx(j,i)=0.0d0
16282               gvdwpp(j,i)=0.0d0
16283               gel_loc(j,i)=0.0d0
16284               gel_loc_long(j,i)=0.0d0
16285               ghpbc(j,i)=0.0D0
16286               ghpbx(j,i)=0.0D0
16287               gcorr3_turn(j,i)=0.0d0
16288               gcorr4_turn(j,i)=0.0d0
16289               gradcorr(j,i)=0.0d0
16290               gradcorr_long(j,i)=0.0d0
16291               gradcorr5_long(j,i)=0.0d0
16292               gradcorr6_long(j,i)=0.0d0
16293               gcorr6_turn_long(j,i)=0.0d0
16294               gradcorr5(j,i)=0.0d0
16295               gradcorr6(j,i)=0.0d0
16296               gcorr6_turn(j,i)=0.0d0
16297               gsccorc(j,i)=0.0d0
16298               gsccorx(j,i)=0.0d0
16299               gradc(j,i,icg)=0.0d0
16300               gradx(j,i,icg)=0.0d0
16301               gscloc(j,i)=0.0d0
16302               gsclocx(j,i)=0.0d0
16303               gliptran(j,i)=0.0d0
16304               gliptranx(j,i)=0.0d0
16305               gliptranc(j,i)=0.0d0
16306               gshieldx(j,i)=0.0d0
16307               gshieldc(j,i)=0.0d0
16308               gshieldc_loc(j,i)=0.0d0
16309               gshieldx_ec(j,i)=0.0d0
16310               gshieldc_ec(j,i)=0.0d0
16311               gshieldc_loc_ec(j,i)=0.0d0
16312               gshieldx_t3(j,i)=0.0d0
16313               gshieldc_t3(j,i)=0.0d0
16314               gshieldc_loc_t3(j,i)=0.0d0
16315               gshieldx_t4(j,i)=0.0d0
16316               gshieldc_t4(j,i)=0.0d0
16317               gshieldc_loc_t4(j,i)=0.0d0
16318               gshieldx_ll(j,i)=0.0d0
16319               gshieldc_ll(j,i)=0.0d0
16320               gshieldc_loc_ll(j,i)=0.0d0
16321               gg_tube(j,i)=0.0d0
16322               gg_tube_sc(j,i)=0.0d0
16323               gradafm(j,i)=0.0d0
16324               gradb_nucl(j,i)=0.0d0
16325               gradbx_nucl(j,i)=0.0d0
16326               gvdwpp_nucl(j,i)=0.0d0
16327               gvdwpp(j,i)=0.0d0
16328               gelpp(j,i)=0.0d0
16329               gvdwpsb(j,i)=0.0d0
16330               gvdwpsb1(j,i)=0.0d0
16331               gvdwsbc(j,i)=0.0d0
16332               gvdwsbx(j,i)=0.0d0
16333               gelsbc(j,i)=0.0d0
16334               gradcorr_nucl(j,i)=0.0d0
16335               gradcorr3_nucl(j,i)=0.0d0
16336               gradxorr_nucl(j,i)=0.0d0
16337               gradxorr3_nucl(j,i)=0.0d0
16338               gelsbx(j,i)=0.0d0
16339               gsbloc(j,i)=0.0d0
16340               gsblocx(j,i)=0.0d0
16341             enddo
16342              enddo
16343             do i=0,nres
16344             do j=1,3
16345               do intertyp=1,3
16346                gloc_sc(intertyp,i,icg)=0.0d0
16347               enddo
16348             enddo
16349             enddo
16350             do i=1,nres
16351              do j=1,maxcontsshi
16352              shield_list(j,i)=0
16353             do k=1,3
16354       !C           print *,i,j,k
16355                grad_shield_side(k,j,i)=0.0d0
16356                grad_shield_loc(k,j,i)=0.0d0
16357              enddo
16358              enddo
16359              ishield_list(i)=0
16360             enddo
16361
16362       !
16363       ! Initialize the gradient of local energy terms.
16364       !
16365       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16366       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16367       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16368       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16369       !      allocate(gel_loc_turn3(nres))
16370       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16371       !      allocate(gsccor_loc(nres))      !(maxres)
16372
16373             do i=1,4*nres
16374             gloc(i,icg)=0.0D0
16375             enddo
16376             do i=1,nres
16377             gel_loc_loc(i)=0.0d0
16378             gcorr_loc(i)=0.0d0
16379             g_corr5_loc(i)=0.0d0
16380             g_corr6_loc(i)=0.0d0
16381             gel_loc_turn3(i)=0.0d0
16382             gel_loc_turn4(i)=0.0d0
16383             gel_loc_turn6(i)=0.0d0
16384             gsccor_loc(i)=0.0d0
16385             enddo
16386       ! initialize gcart and gxcart
16387       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16388             do i=0,nres
16389             do j=1,3
16390               gcart(j,i)=0.0d0
16391               gxcart(j,i)=0.0d0
16392             enddo
16393             enddo
16394             return
16395             end subroutine zerograd
16396       !-----------------------------------------------------------------------------
16397             real(kind=8) function fdum()
16398             fdum=0.0D0
16399             return
16400             end function fdum
16401       !-----------------------------------------------------------------------------
16402       ! intcartderiv.F
16403       !-----------------------------------------------------------------------------
16404             subroutine intcartderiv
16405       !      implicit real*8 (a-h,o-z)
16406       !      include 'DIMENSIONS'
16407 #ifdef MPI
16408             include 'mpif.h'
16409 #endif
16410       !      include 'COMMON.SETUP'
16411       !      include 'COMMON.CHAIN'
16412       !      include 'COMMON.VAR'
16413       !      include 'COMMON.GEO'
16414       !      include 'COMMON.INTERACT'
16415       !      include 'COMMON.DERIV'
16416       !      include 'COMMON.IOUNITS'
16417       !      include 'COMMON.LOCAL'
16418       !      include 'COMMON.SCCOR'
16419             real(kind=8) :: pi4,pi34
16420             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16421             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16422                       dcosomega,dsinomega !(3,3,maxres)
16423             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16424
16425             integer :: i,j,k
16426             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16427                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16428                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16429                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16430             integer :: nres2
16431             nres2=2*nres
16432
16433       !el from module energy-------------
16434       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16435       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16436       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16437
16438       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16439       !el      allocate(dsintau(3,3,3,0:nres2))
16440       !el      allocate(dtauangle(3,3,3,0:nres2))
16441       !el      allocate(domicron(3,2,2,0:nres2))
16442       !el      allocate(dcosomicron(3,2,2,0:nres2))
16443
16444
16445
16446 #if defined(MPI) && defined(PARINTDER)
16447             if (nfgtasks.gt.1 .and. me.eq.king) &
16448             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16449 #endif
16450             pi4 = 0.5d0*pipol
16451             pi34 = 3*pi4
16452
16453       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
16454       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16455
16456       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16457             do i=1,nres
16458             do j=1,3
16459               dtheta(j,1,i)=0.0d0
16460               dtheta(j,2,i)=0.0d0
16461               dphi(j,1,i)=0.0d0
16462               dphi(j,2,i)=0.0d0
16463               dphi(j,3,i)=0.0d0
16464             enddo
16465             enddo
16466       ! Derivatives of theta's
16467 #if defined(MPI) && defined(PARINTDER)
16468       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16469             do i=max0(ithet_start-1,3),ithet_end
16470 #else
16471             do i=3,nres
16472 #endif
16473             cost=dcos(theta(i))
16474             sint=sqrt(1-cost*cost)
16475             do j=1,3
16476               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16477               vbld(i-1)
16478               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16479               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16480               vbld(i)
16481               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16482             enddo
16483             enddo
16484 #if defined(MPI) && defined(PARINTDER)
16485       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16486             do i=max0(ithet_start-1,3),ithet_end
16487 #else
16488             do i=3,nres
16489 #endif
16490             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16491             cost1=dcos(omicron(1,i))
16492             sint1=sqrt(1-cost1*cost1)
16493             cost2=dcos(omicron(2,i))
16494             sint2=sqrt(1-cost2*cost2)
16495              do j=1,3
16496       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16497               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16498               cost1*dc_norm(j,i-2))/ &
16499               vbld(i-1)
16500               domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16501               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16502               +cost1*(dc_norm(j,i-1+nres)))/ &
16503               vbld(i-1+nres)
16504               domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16505       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16506       !C Looks messy but better than if in loop
16507               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16508               +cost2*dc_norm(j,i-1))/ &
16509               vbld(i)
16510               domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16511               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16512                +cost2*(-dc_norm(j,i-1+nres)))/ &
16513               vbld(i-1+nres)
16514       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16515               domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16516             enddo
16517              endif
16518             enddo
16519       !elwrite(iout,*) "after vbld write"
16520       ! Derivatives of phi:
16521       ! If phi is 0 or 180 degrees, then the formulas
16522       ! have to be derived by power series expansion of the
16523       ! conventional formulas around 0 and 180.
16524 #ifdef PARINTDER
16525             do i=iphi1_start,iphi1_end
16526 #else
16527             do i=4,nres
16528 #endif
16529       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16530       ! the conventional case
16531             sint=dsin(theta(i))
16532             sint1=dsin(theta(i-1))
16533             sing=dsin(phi(i))
16534             cost=dcos(theta(i))
16535             cost1=dcos(theta(i-1))
16536             cosg=dcos(phi(i))
16537             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16538             fac0=1.0d0/(sint1*sint)
16539             fac1=cost*fac0
16540             fac2=cost1*fac0
16541             fac3=cosg*cost1/(sint1*sint1)
16542             fac4=cosg*cost/(sint*sint)
16543       !    Obtaining the gamma derivatives from sine derivative
16544              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16545                phi(i).gt.pi34.and.phi(i).le.pi.or. &
16546                phi(i).ge.-pi.and.phi(i).le.-pi34) then
16547              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16548              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16549              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16550              do j=1,3
16551                 ctgt=cost/sint
16552                 ctgt1=cost1/sint1
16553                 cosg_inv=1.0d0/cosg
16554                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16555                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16556                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16557                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16558                 dsinphi(j,2,i)= &
16559                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16560                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16561                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16562                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16563                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16564       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16565                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16566                 endif
16567       ! Bug fixed 3/24/05 (AL)
16568              enddo
16569       !   Obtaining the gamma derivatives from cosine derivative
16570             else
16571                do j=1,3
16572                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16573                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16574                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16575                dc_norm(j,i-3))/vbld(i-2)
16576                dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16577                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16578                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16579                dcostheta(j,1,i)
16580                dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16581                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16582                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16583                dc_norm(j,i-1))/vbld(i)
16584                dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16585                endif
16586              enddo
16587             endif
16588             enddo
16589       !alculate derivative of Tauangle
16590 #ifdef PARINTDER
16591             do i=itau_start,itau_end
16592 #else
16593             do i=3,nres
16594       !elwrite(iout,*) " vecpr",i,nres
16595 #endif
16596              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16597       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16598       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16599       !c dtauangle(j,intertyp,dervityp,residue number)
16600       !c INTERTYP=1 SC...Ca...Ca..Ca
16601       ! the conventional case
16602             sint=dsin(theta(i))
16603             sint1=dsin(omicron(2,i-1))
16604             sing=dsin(tauangle(1,i))
16605             cost=dcos(theta(i))
16606             cost1=dcos(omicron(2,i-1))
16607             cosg=dcos(tauangle(1,i))
16608       !elwrite(iout,*) " vecpr5",i,nres
16609             do j=1,3
16610       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16611       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16612             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16613       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16614             enddo
16615             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16616             fac0=1.0d0/(sint1*sint)
16617             fac1=cost*fac0
16618             fac2=cost1*fac0
16619             fac3=cosg*cost1/(sint1*sint1)
16620             fac4=cosg*cost/(sint*sint)
16621       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16622       !    Obtaining the gamma derivatives from sine derivative
16623              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16624                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16625                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16626              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16627              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16628              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16629             do j=1,3
16630                 ctgt=cost/sint
16631                 ctgt1=cost1/sint1
16632                 cosg_inv=1.0d0/cosg
16633                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16634              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16635              *vbld_inv(i-2+nres)
16636                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16637                 dsintau(j,1,2,i)= &
16638                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16639                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16640       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16641                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16642       ! Bug fixed 3/24/05 (AL)
16643                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16644                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16645       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16646                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16647              enddo
16648       !   Obtaining the gamma derivatives from cosine derivative
16649             else
16650                do j=1,3
16651                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16652                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16653                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16654                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16655                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16656                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16657                dcostheta(j,1,i)
16658                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16659                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16660                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16661                dc_norm(j,i-1))/vbld(i)
16662                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16663       !         write (iout,*) "else",i
16664              enddo
16665             endif
16666       !        do k=1,3
16667       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16668       !        enddo
16669             enddo
16670       !C Second case Ca...Ca...Ca...SC
16671 #ifdef PARINTDER
16672             do i=itau_start,itau_end
16673 #else
16674             do i=4,nres
16675 #endif
16676              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16677               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16678       ! the conventional case
16679             sint=dsin(omicron(1,i))
16680             sint1=dsin(theta(i-1))
16681             sing=dsin(tauangle(2,i))
16682             cost=dcos(omicron(1,i))
16683             cost1=dcos(theta(i-1))
16684             cosg=dcos(tauangle(2,i))
16685       !        do j=1,3
16686       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16687       !        enddo
16688             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16689             fac0=1.0d0/(sint1*sint)
16690             fac1=cost*fac0
16691             fac2=cost1*fac0
16692             fac3=cosg*cost1/(sint1*sint1)
16693             fac4=cosg*cost/(sint*sint)
16694       !    Obtaining the gamma derivatives from sine derivative
16695              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16696                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16697                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16698              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16699              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16700              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16701             do j=1,3
16702                 ctgt=cost/sint
16703                 ctgt1=cost1/sint1
16704                 cosg_inv=1.0d0/cosg
16705                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16706                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16707       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16708       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16709                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16710                 dsintau(j,2,2,i)= &
16711                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16712                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16713       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16714       !     & sing*ctgt*domicron(j,1,2,i),
16715       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16716                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16717       ! Bug fixed 3/24/05 (AL)
16718                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16719                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16720       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16721                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16722              enddo
16723       !   Obtaining the gamma derivatives from cosine derivative
16724             else
16725                do j=1,3
16726                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16727                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16728                dc_norm(j,i-3))/vbld(i-2)
16729                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16730                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16731                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16732                dcosomicron(j,1,1,i)
16733                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16734                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16735                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16736                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16737                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16738       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16739              enddo
16740             endif
16741             enddo
16742
16743       !CC third case SC...Ca...Ca...SC
16744 #ifdef PARINTDER
16745
16746             do i=itau_start,itau_end
16747 #else
16748             do i=3,nres
16749 #endif
16750       ! the conventional case
16751             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16752             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16753             sint=dsin(omicron(1,i))
16754             sint1=dsin(omicron(2,i-1))
16755             sing=dsin(tauangle(3,i))
16756             cost=dcos(omicron(1,i))
16757             cost1=dcos(omicron(2,i-1))
16758             cosg=dcos(tauangle(3,i))
16759             do j=1,3
16760             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16761       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16762             enddo
16763             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16764             fac0=1.0d0/(sint1*sint)
16765             fac1=cost*fac0
16766             fac2=cost1*fac0
16767             fac3=cosg*cost1/(sint1*sint1)
16768             fac4=cosg*cost/(sint*sint)
16769       !    Obtaining the gamma derivatives from sine derivative
16770              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16771                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16772                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16773              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16774              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16775              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16776             do j=1,3
16777                 ctgt=cost/sint
16778                 ctgt1=cost1/sint1
16779                 cosg_inv=1.0d0/cosg
16780                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16781                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16782                   *vbld_inv(i-2+nres)
16783                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16784                 dsintau(j,3,2,i)= &
16785                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16786                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16787                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16788       ! Bug fixed 3/24/05 (AL)
16789                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16790                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16791                   *vbld_inv(i-1+nres)
16792       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16793                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16794              enddo
16795       !   Obtaining the gamma derivatives from cosine derivative
16796             else
16797                do j=1,3
16798                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16799                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16800                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16801                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16802                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16803                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16804                dcosomicron(j,1,1,i)
16805                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16806                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16807                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16808                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16809                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16810       !          write(iout,*) "else",i
16811              enddo
16812             endif
16813             enddo
16814
16815 #ifdef CRYST_SC
16816       !   Derivatives of side-chain angles alpha and omega
16817 #if defined(MPI) && defined(PARINTDER)
16818             do i=ibond_start,ibond_end
16819 #else
16820             do i=2,nres-1
16821 #endif
16822               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16823                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16824                  fac6=fac5/vbld(i)
16825                  fac7=fac5*fac5
16826                  fac8=fac5/vbld(i+1)
16827                  fac9=fac5/vbld(i+nres)
16828                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16829                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16830                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16831                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16832                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16833                  sina=sqrt(1-cosa*cosa)
16834                  sino=dsin(omeg(i))
16835       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16836                  do j=1,3
16837                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16838                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16839                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16840                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16841                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16842                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16843                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16844                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16845                   vbld(i+nres))
16846                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16847                 enddo
16848       ! obtaining the derivatives of omega from sines
16849                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16850                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16851                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16852                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16853                    dsin(theta(i+1)))
16854                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16855                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16856                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16857                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16858                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16859                    coso_inv=1.0d0/dcos(omeg(i))
16860                    do j=1,3
16861                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16862                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16863                    (sino*dc_norm(j,i-1))/vbld(i)
16864                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16865                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16866                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16867                    -sino*dc_norm(j,i)/vbld(i+1)
16868                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16869                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16870                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16871                    vbld(i+nres)
16872                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16873                   enddo
16874                else
16875       !   obtaining the derivatives of omega from cosines
16876                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16877                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16878                  fac12=fac10*sina
16879                  fac13=fac12*fac12
16880                  fac14=sina*sina
16881                  do j=1,3
16882                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16883                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16884                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16885                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16886                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
16887                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
16888                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
16889                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
16890                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
16891                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
16892                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
16893                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
16894                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
16895                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
16896                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
16897                 enddo
16898               endif
16899              else
16900                do j=1,3
16901                  do k=1,3
16902                    dalpha(k,j,i)=0.0d0
16903                    domega(k,j,i)=0.0d0
16904                  enddo
16905                enddo
16906              endif
16907              enddo
16908 #endif
16909 #if defined(MPI) && defined(PARINTDER)
16910             if (nfgtasks.gt.1) then
16911 #ifdef DEBUG
16912       !d      write (iout,*) "Gather dtheta"
16913       !d      call flush(iout)
16914             write (iout,*) "dtheta before gather"
16915             do i=1,nres
16916             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
16917             enddo
16918 #endif
16919             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
16920             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
16921             king,FG_COMM,IERROR)
16922 #ifdef DEBUG
16923       !d      write (iout,*) "Gather dphi"
16924       !d      call flush(iout)
16925             write (iout,*) "dphi before gather"
16926             do i=1,nres
16927             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
16928             enddo
16929 #endif
16930             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
16931             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
16932             king,FG_COMM,IERROR)
16933       !d      write (iout,*) "Gather dalpha"
16934       !d      call flush(iout)
16935 #ifdef CRYST_SC
16936             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
16937             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16938             king,FG_COMM,IERROR)
16939       !d      write (iout,*) "Gather domega"
16940       !d      call flush(iout)
16941             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
16942             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16943             king,FG_COMM,IERROR)
16944 #endif
16945             endif
16946 #endif
16947 #ifdef DEBUG
16948             write (iout,*) "dtheta after gather"
16949             do i=1,nres
16950             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
16951             enddo
16952             write (iout,*) "dphi after gather"
16953             do i=1,nres
16954             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
16955             enddo
16956             write (iout,*) "dalpha after gather"
16957             do i=1,nres
16958             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
16959             enddo
16960             write (iout,*) "domega after gather"
16961             do i=1,nres
16962             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
16963             enddo
16964 #endif
16965             return
16966             end subroutine intcartderiv
16967       !-----------------------------------------------------------------------------
16968             subroutine checkintcartgrad
16969       !      implicit real*8 (a-h,o-z)
16970       !      include 'DIMENSIONS'
16971 #ifdef MPI
16972             include 'mpif.h'
16973 #endif
16974       !      include 'COMMON.CHAIN'
16975       !      include 'COMMON.VAR'
16976       !      include 'COMMON.GEO'
16977       !      include 'COMMON.INTERACT'
16978       !      include 'COMMON.DERIV'
16979       !      include 'COMMON.IOUNITS'
16980       !      include 'COMMON.SETUP'
16981             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
16982             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
16983             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
16984             real(kind=8),dimension(3) :: dc_norm_s
16985             real(kind=8) :: aincr=1.0d-5
16986             integer :: i,j
16987             real(kind=8) :: dcji
16988             do i=1,nres
16989             phi_s(i)=phi(i)
16990             theta_s(i)=theta(i)
16991             alph_s(i)=alph(i)
16992             omeg_s(i)=omeg(i)
16993             enddo
16994       ! Check theta gradient
16995             write (iout,*) &
16996              "Analytical (upper) and numerical (lower) gradient of theta"
16997             write (iout,*)
16998             do i=3,nres
16999             do j=1,3
17000               dcji=dc(j,i-2)
17001               dc(j,i-2)=dcji+aincr
17002               call chainbuild_cart
17003               call int_from_cart1(.false.)
17004           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17005           dc(j,i-2)=dcji
17006           dcji=dc(j,i-1)
17007           dc(j,i-1)=dc(j,i-1)+aincr
17008           call chainbuild_cart
17009           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17010           dc(j,i-1)=dcji
17011         enddo
17012 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17013 !el          (dtheta(j,2,i),j=1,3)
17014 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17015 !el          (dthetanum(j,2,i),j=1,3)
17016 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17017 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17018 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17019 !el        write (iout,*)
17020       enddo
17021 ! Check gamma gradient
17022       write (iout,*) &
17023        "Analytical (upper) and numerical (lower) gradient of gamma"
17024       do i=4,nres
17025         do j=1,3
17026           dcji=dc(j,i-3)
17027           dc(j,i-3)=dcji+aincr
17028           call chainbuild_cart
17029           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17030               dc(j,i-3)=dcji
17031           dcji=dc(j,i-2)
17032           dc(j,i-2)=dcji+aincr
17033           call chainbuild_cart
17034           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17035           dc(j,i-2)=dcji
17036           dcji=dc(j,i-1)
17037           dc(j,i-1)=dc(j,i-1)+aincr
17038           call chainbuild_cart
17039           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17040           dc(j,i-1)=dcji
17041         enddo
17042 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17043 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17044 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17045 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17046 !el        write (iout,'(5x,3(3f10.5,5x))') &
17047 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17048 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17049 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17050 !el        write (iout,*)
17051       enddo
17052 ! Check alpha gradient
17053       write (iout,*) &
17054        "Analytical (upper) and numerical (lower) gradient of alpha"
17055       do i=2,nres-1
17056        if(itype(i,1).ne.10) then
17057                  do j=1,3
17058                   dcji=dc(j,i-1)
17059                    dc(j,i-1)=dcji+aincr
17060               call chainbuild_cart
17061               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17062                  /aincr
17063                   dc(j,i-1)=dcji
17064               dcji=dc(j,i)
17065               dc(j,i)=dcji+aincr
17066               call chainbuild_cart
17067               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17068                  /aincr
17069               dc(j,i)=dcji
17070               dcji=dc(j,i+nres)
17071               dc(j,i+nres)=dc(j,i+nres)+aincr
17072               call chainbuild_cart
17073               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17074                  /aincr
17075              dc(j,i+nres)=dcji
17076             enddo
17077           endif
17078 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17079 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17080 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17081 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17082 !el        write (iout,'(5x,3(3f10.5,5x))') &
17083 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17084 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17085 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17086 !el        write (iout,*)
17087       enddo
17088 !     Check omega gradient
17089       write (iout,*) &
17090        "Analytical (upper) and numerical (lower) gradient of omega"
17091       do i=2,nres-1
17092        if(itype(i,1).ne.10) then
17093                  do j=1,3
17094                   dcji=dc(j,i-1)
17095                    dc(j,i-1)=dcji+aincr
17096               call chainbuild_cart
17097               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17098                  /aincr
17099                   dc(j,i-1)=dcji
17100               dcji=dc(j,i)
17101               dc(j,i)=dcji+aincr
17102               call chainbuild_cart
17103               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17104                  /aincr
17105               dc(j,i)=dcji
17106               dcji=dc(j,i+nres)
17107               dc(j,i+nres)=dc(j,i+nres)+aincr
17108               call chainbuild_cart
17109               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17110                  /aincr
17111              dc(j,i+nres)=dcji
17112             enddo
17113           endif
17114 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17115 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17116 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17117 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17118 !el        write (iout,'(5x,3(3f10.5,5x))') &
17119 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17120 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17121 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17122 !el        write (iout,*)
17123       enddo
17124       return
17125       end subroutine checkintcartgrad
17126 !-----------------------------------------------------------------------------
17127 ! q_measure.F
17128 !-----------------------------------------------------------------------------
17129       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17130 !      implicit real*8 (a-h,o-z)
17131 !      include 'DIMENSIONS'
17132 !      include 'COMMON.IOUNITS'
17133 !      include 'COMMON.CHAIN'
17134 !      include 'COMMON.INTERACT'
17135 !      include 'COMMON.VAR'
17136       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17137       integer :: kkk,nsep=3
17138       real(kind=8) :: qm      !dist,
17139       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17140       logical :: lprn=.false.
17141       logical :: flag
17142 !      real(kind=8) :: sigm,x
17143
17144 !el      sigm(x)=0.25d0*x     ! local function
17145       qqmax=1.0d10
17146       do kkk=1,nperm
17147       qq = 0.0d0
17148       nl=0
17149        if(flag) then
17150         do il=seg1+nsep,seg2
17151           do jl=seg1,il-nsep
17152             nl=nl+1
17153             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17154                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17155                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17156             dij=dist(il,jl)
17157             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17158             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17159               nl=nl+1
17160               d0ijCM=dsqrt( &
17161                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17162                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17163                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17164               dijCM=dist(il+nres,jl+nres)
17165               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17166             endif
17167             qq = qq+qqij+qqijCM
17168           enddo
17169         enddo
17170         qq = qq/nl
17171       else
17172       do il=seg1,seg2
17173         if((seg3-il).lt.3) then
17174              secseg=il+3
17175         else
17176              secseg=seg3
17177         endif
17178           do jl=secseg,seg4
17179             nl=nl+1
17180             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17181                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17182                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17183             dij=dist(il,jl)
17184             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17185             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17186               nl=nl+1
17187               d0ijCM=dsqrt( &
17188                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17189                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17190                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17191               dijCM=dist(il+nres,jl+nres)
17192               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17193             endif
17194             qq = qq+qqij+qqijCM
17195           enddo
17196         enddo
17197       qq = qq/nl
17198       endif
17199       if (qqmax.le.qq) qqmax=qq
17200       enddo
17201       qwolynes=1.0d0-qqmax
17202       return
17203       end function qwolynes
17204 !-----------------------------------------------------------------------------
17205       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17206 !      implicit real*8 (a-h,o-z)
17207 !      include 'DIMENSIONS'
17208 !      include 'COMMON.IOUNITS'
17209 !      include 'COMMON.CHAIN'
17210 !      include 'COMMON.INTERACT'
17211 !      include 'COMMON.VAR'
17212 !      include 'COMMON.MD'
17213       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17214       integer :: nsep=3, kkk
17215 !el      real(kind=8) :: dist
17216       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17217       logical :: lprn=.false.
17218       logical :: flag
17219       real(kind=8) :: sim,dd0,fac,ddqij
17220 !el      sigm(x)=0.25d0*x           ! local function
17221       do kkk=1,nperm
17222       do i=0,nres
17223         do j=1,3
17224           dqwol(j,i)=0.0d0
17225           dxqwol(j,i)=0.0d0
17226         enddo
17227       enddo
17228       nl=0
17229        if(flag) then
17230         do il=seg1+nsep,seg2
17231           do jl=seg1,il-nsep
17232             nl=nl+1
17233             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17234                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17235                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17236             dij=dist(il,jl)
17237             sim = 1.0d0/sigm(d0ij)
17238             sim = sim*sim
17239             dd0 = dij-d0ij
17240             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17241           do k=1,3
17242               ddqij = (c(k,il)-c(k,jl))*fac
17243               dqwol(k,il)=dqwol(k,il)+ddqij
17244               dqwol(k,jl)=dqwol(k,jl)-ddqij
17245             enddo
17246
17247             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17248               nl=nl+1
17249               d0ijCM=dsqrt( &
17250                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17251                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17252                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17253               dijCM=dist(il+nres,jl+nres)
17254               sim = 1.0d0/sigm(d0ijCM)
17255               sim = sim*sim
17256               dd0=dijCM-d0ijCM
17257               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17258               do k=1,3
17259                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17260                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17261                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17262               enddo
17263             endif
17264           enddo
17265         enddo
17266        else
17267         do il=seg1,seg2
17268         if((seg3-il).lt.3) then
17269              secseg=il+3
17270         else
17271              secseg=seg3
17272         endif
17273           do jl=secseg,seg4
17274             nl=nl+1
17275             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17276                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17277                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17278             dij=dist(il,jl)
17279             sim = 1.0d0/sigm(d0ij)
17280             sim = sim*sim
17281             dd0 = dij-d0ij
17282             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17283             do k=1,3
17284               ddqij = (c(k,il)-c(k,jl))*fac
17285               dqwol(k,il)=dqwol(k,il)+ddqij
17286               dqwol(k,jl)=dqwol(k,jl)-ddqij
17287             enddo
17288             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17289               nl=nl+1
17290               d0ijCM=dsqrt( &
17291                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17292                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17293                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17294               dijCM=dist(il+nres,jl+nres)
17295               sim = 1.0d0/sigm(d0ijCM)
17296               sim=sim*sim
17297               dd0 = dijCM-d0ijCM
17298               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17299               do k=1,3
17300                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17301                dxqwol(k,il)=dxqwol(k,il)+ddqij
17302                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17303               enddo
17304             endif
17305           enddo
17306         enddo
17307       endif
17308       enddo
17309        do i=0,nres
17310          do j=1,3
17311            dqwol(j,i)=dqwol(j,i)/nl
17312            dxqwol(j,i)=dxqwol(j,i)/nl
17313          enddo
17314        enddo
17315       return
17316       end subroutine qwolynes_prim
17317 !-----------------------------------------------------------------------------
17318       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17319 !      implicit real*8 (a-h,o-z)
17320 !      include 'DIMENSIONS'
17321 !      include 'COMMON.IOUNITS'
17322 !      include 'COMMON.CHAIN'
17323 !      include 'COMMON.INTERACT'
17324 !      include 'COMMON.VAR'
17325       integer :: seg1,seg2,seg3,seg4
17326       logical :: flag
17327       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17328       real(kind=8),dimension(3,0:2*nres) :: cdummy
17329       real(kind=8) :: q1,q2
17330       real(kind=8) :: delta=1.0d-10
17331       integer :: i,j
17332
17333       do i=0,nres
17334         do j=1,3
17335           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17336           cdummy(j,i)=c(j,i)
17337           c(j,i)=c(j,i)+delta
17338           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17339           qwolan(j,i)=(q2-q1)/delta
17340           c(j,i)=cdummy(j,i)
17341         enddo
17342       enddo
17343       do i=0,nres
17344         do j=1,3
17345           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17346           cdummy(j,i+nres)=c(j,i+nres)
17347           c(j,i+nres)=c(j,i+nres)+delta
17348           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17349           qwolxan(j,i)=(q2-q1)/delta
17350           c(j,i+nres)=cdummy(j,i+nres)
17351         enddo
17352       enddo
17353 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17354 !      do i=0,nct
17355 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17356 !      enddo
17357 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17358 !      do i=0,nct
17359 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17360 !      enddo
17361       return
17362       end subroutine qwol_num
17363 !-----------------------------------------------------------------------------
17364       subroutine EconstrQ
17365 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17366 !      implicit real*8 (a-h,o-z)
17367 !      include 'DIMENSIONS'
17368 !      include 'COMMON.CONTROL'
17369 !      include 'COMMON.VAR'
17370 !      include 'COMMON.MD'
17371       use MD_data
17372 !#ifndef LANG0
17373 !      include 'COMMON.LANGEVIN'
17374 !#else
17375 !      include 'COMMON.LANGEVIN.lang0'
17376 !#endif
17377 !      include 'COMMON.CHAIN'
17378 !      include 'COMMON.DERIV'
17379 !      include 'COMMON.GEO'
17380 !      include 'COMMON.LOCAL'
17381 !      include 'COMMON.INTERACT'
17382 !      include 'COMMON.IOUNITS'
17383 !      include 'COMMON.NAMES'
17384 !      include 'COMMON.TIME1'
17385       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17386       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17387                    duconst,duxconst
17388       integer :: kstart,kend,lstart,lend,idummy
17389       real(kind=8) :: delta=1.0d-7
17390       integer :: i,j,k,ii
17391       do i=0,nres
17392          do j=1,3
17393             duconst(j,i)=0.0d0
17394             dudconst(j,i)=0.0d0
17395             duxconst(j,i)=0.0d0
17396             dudxconst(j,i)=0.0d0
17397          enddo
17398       enddo
17399       Uconst=0.0d0
17400       do i=1,nfrag
17401          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17402            idummy,idummy)
17403          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17404 ! Calculating the derivatives of Constraint energy with respect to Q
17405          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17406            qinfrag(i,iset))
17407 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17408 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17409 !         hmnum=(hm2-hm1)/delta
17410 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17411 !     &   qinfrag(i,iset))
17412 !         write(iout,*) "harmonicnum frag", hmnum
17413 ! Calculating the derivatives of Q with respect to cartesian coordinates
17414          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17415           idummy,idummy)
17416 !         write(iout,*) "dqwol "
17417 !         do ii=1,nres
17418 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17419 !         enddo
17420 !         write(iout,*) "dxqwol "
17421 !         do ii=1,nres
17422 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17423 !         enddo
17424 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17425 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17426 !     &  ,idummy,idummy)
17427 !  The gradients of Uconst in Cs
17428          do ii=0,nres
17429             do j=1,3
17430                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17431                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17432             enddo
17433          enddo
17434       enddo
17435       do i=1,npair
17436          kstart=ifrag(1,ipair(1,i,iset),iset)
17437          kend=ifrag(2,ipair(1,i,iset),iset)
17438          lstart=ifrag(1,ipair(2,i,iset),iset)
17439          lend=ifrag(2,ipair(2,i,iset),iset)
17440          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17441          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17442 !  Calculating dU/dQ
17443          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17444 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17445 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17446 !         hmnum=(hm2-hm1)/delta
17447 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17448 !     &   qinpair(i,iset))
17449 !         write(iout,*) "harmonicnum pair ", hmnum
17450 ! Calculating dQ/dXi
17451          call qwolynes_prim(kstart,kend,.false.,&
17452           lstart,lend)
17453 !         write(iout,*) "dqwol "
17454 !         do ii=1,nres
17455 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17456 !         enddo
17457 !         write(iout,*) "dxqwol "
17458 !         do ii=1,nres
17459 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17460 !        enddo
17461 ! Calculating numerical gradients
17462 !        call qwol_num(kstart,kend,.false.
17463 !     &  ,lstart,lend)
17464 ! The gradients of Uconst in Cs
17465          do ii=0,nres
17466             do j=1,3
17467                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17468                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17469             enddo
17470          enddo
17471       enddo
17472 !      write(iout,*) "Uconst inside subroutine ", Uconst
17473 ! Transforming the gradients from Cs to dCs for the backbone
17474       do i=0,nres
17475          do j=i+1,nres
17476            do k=1,3
17477              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17478            enddo
17479          enddo
17480       enddo
17481 !  Transforming the gradients from Cs to dCs for the side chains
17482       do i=1,nres
17483          do j=1,3
17484            dudxconst(j,i)=duxconst(j,i)
17485          enddo
17486       enddo
17487 !      write(iout,*) "dU/ddc backbone "
17488 !       do ii=0,nres
17489 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17490 !      enddo
17491 !      write(iout,*) "dU/ddX side chain "
17492 !      do ii=1,nres
17493 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17494 !      enddo
17495 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17496 !      call dEconstrQ_num
17497       return
17498       end subroutine EconstrQ
17499 !-----------------------------------------------------------------------------
17500       subroutine dEconstrQ_num
17501 ! Calculating numerical dUconst/ddc and dUconst/ddx
17502 !      implicit real*8 (a-h,o-z)
17503 !      include 'DIMENSIONS'
17504 !      include 'COMMON.CONTROL'
17505 !      include 'COMMON.VAR'
17506 !      include 'COMMON.MD'
17507       use MD_data
17508 !#ifndef LANG0
17509 !      include 'COMMON.LANGEVIN'
17510 !#else
17511 !      include 'COMMON.LANGEVIN.lang0'
17512 !#endif
17513 !      include 'COMMON.CHAIN'
17514 !      include 'COMMON.DERIV'
17515 !      include 'COMMON.GEO'
17516 !      include 'COMMON.LOCAL'
17517 !      include 'COMMON.INTERACT'
17518 !      include 'COMMON.IOUNITS'
17519 !      include 'COMMON.NAMES'
17520 !      include 'COMMON.TIME1'
17521       real(kind=8) :: uzap1,uzap2
17522       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17523       integer :: kstart,kend,lstart,lend,idummy
17524       real(kind=8) :: delta=1.0d-7
17525 !el local variables
17526       integer :: i,ii,j
17527 !     real(kind=8) ::
17528 !     For the backbone
17529       do i=0,nres-1
17530          do j=1,3
17531             dUcartan(j,i)=0.0d0
17532             cdummy(j,i)=dc(j,i)
17533             dc(j,i)=dc(j,i)+delta
17534             call chainbuild_cart
17535           uzap2=0.0d0
17536             do ii=1,nfrag
17537              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17538                 idummy,idummy)
17539                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17540                 qinfrag(ii,iset))
17541             enddo
17542             do ii=1,npair
17543                kstart=ifrag(1,ipair(1,ii,iset),iset)
17544                kend=ifrag(2,ipair(1,ii,iset),iset)
17545                lstart=ifrag(1,ipair(2,ii,iset),iset)
17546                lend=ifrag(2,ipair(2,ii,iset),iset)
17547                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17548                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17549                  qinpair(ii,iset))
17550             enddo
17551             dc(j,i)=cdummy(j,i)
17552             call chainbuild_cart
17553             uzap1=0.0d0
17554              do ii=1,nfrag
17555              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17556                 idummy,idummy)
17557                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17558                 qinfrag(ii,iset))
17559             enddo
17560             do ii=1,npair
17561                kstart=ifrag(1,ipair(1,ii,iset),iset)
17562                kend=ifrag(2,ipair(1,ii,iset),iset)
17563                lstart=ifrag(1,ipair(2,ii,iset),iset)
17564                lend=ifrag(2,ipair(2,ii,iset),iset)
17565                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17566                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17567                 qinpair(ii,iset))
17568             enddo
17569             ducartan(j,i)=(uzap2-uzap1)/(delta)
17570          enddo
17571       enddo
17572 ! Calculating numerical gradients for dU/ddx
17573       do i=0,nres-1
17574          duxcartan(j,i)=0.0d0
17575          do j=1,3
17576             cdummy(j,i)=dc(j,i+nres)
17577             dc(j,i+nres)=dc(j,i+nres)+delta
17578             call chainbuild_cart
17579           uzap2=0.0d0
17580             do ii=1,nfrag
17581              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17582                 idummy,idummy)
17583                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17584                 qinfrag(ii,iset))
17585             enddo
17586             do ii=1,npair
17587                kstart=ifrag(1,ipair(1,ii,iset),iset)
17588                kend=ifrag(2,ipair(1,ii,iset),iset)
17589                lstart=ifrag(1,ipair(2,ii,iset),iset)
17590                lend=ifrag(2,ipair(2,ii,iset),iset)
17591                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17592                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17593                 qinpair(ii,iset))
17594             enddo
17595             dc(j,i+nres)=cdummy(j,i)
17596             call chainbuild_cart
17597             uzap1=0.0d0
17598              do ii=1,nfrag
17599                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17600                 ifrag(2,ii,iset),.true.,idummy,idummy)
17601                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17602                 qinfrag(ii,iset))
17603             enddo
17604             do ii=1,npair
17605                kstart=ifrag(1,ipair(1,ii,iset),iset)
17606                kend=ifrag(2,ipair(1,ii,iset),iset)
17607                lstart=ifrag(1,ipair(2,ii,iset),iset)
17608                lend=ifrag(2,ipair(2,ii,iset),iset)
17609                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17610                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17611                 qinpair(ii,iset))
17612             enddo
17613             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17614          enddo
17615       enddo
17616       write(iout,*) "Numerical dUconst/ddc backbone "
17617       do ii=0,nres
17618         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17619       enddo
17620 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17621 !      do ii=1,nres
17622 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17623 !      enddo
17624       return
17625       end subroutine dEconstrQ_num
17626 !-----------------------------------------------------------------------------
17627 ! ssMD.F
17628 !-----------------------------------------------------------------------------
17629       subroutine check_energies
17630
17631 !      use random, only: ran_number
17632
17633 !      implicit none
17634 !     Includes
17635 !      include 'DIMENSIONS'
17636 !      include 'COMMON.CHAIN'
17637 !      include 'COMMON.VAR'
17638 !      include 'COMMON.IOUNITS'
17639 !      include 'COMMON.SBRIDGE'
17640 !      include 'COMMON.LOCAL'
17641 !      include 'COMMON.GEO'
17642
17643 !     External functions
17644 !EL      double precision ran_number
17645 !EL      external ran_number
17646
17647 !     Local variables
17648       integer :: i,j,k,l,lmax,p,pmax
17649       real(kind=8) :: rmin,rmax
17650       real(kind=8) :: eij
17651
17652       real(kind=8) :: d
17653       real(kind=8) :: wi,rij,tj,pj
17654 !      return
17655
17656       i=5
17657       j=14
17658
17659       d=dsc(1)
17660       rmin=2.0D0
17661       rmax=12.0D0
17662
17663       lmax=10000
17664       pmax=1
17665
17666       do k=1,3
17667         c(k,i)=0.0D0
17668         c(k,j)=0.0D0
17669         c(k,nres+i)=0.0D0
17670         c(k,nres+j)=0.0D0
17671       enddo
17672
17673       do l=1,lmax
17674
17675 !t        wi=ran_number(0.0D0,pi)
17676 !        wi=ran_number(0.0D0,pi/6.0D0)
17677 !        wi=0.0D0
17678 !t        tj=ran_number(0.0D0,pi)
17679 !t        pj=ran_number(0.0D0,pi)
17680 !        pj=ran_number(0.0D0,pi/6.0D0)
17681 !        pj=0.0D0
17682
17683         do p=1,pmax
17684 !t           rij=ran_number(rmin,rmax)
17685
17686            c(1,j)=d*sin(pj)*cos(tj)
17687            c(2,j)=d*sin(pj)*sin(tj)
17688            c(3,j)=d*cos(pj)
17689
17690            c(3,nres+i)=-rij
17691
17692            c(1,i)=d*sin(wi)
17693            c(3,i)=-rij-d*cos(wi)
17694
17695            do k=1,3
17696               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17697               dc_norm(k,nres+i)=dc(k,nres+i)/d
17698               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17699               dc_norm(k,nres+j)=dc(k,nres+j)/d
17700            enddo
17701
17702            call dyn_ssbond_ene(i,j,eij)
17703         enddo
17704       enddo
17705       call exit(1)
17706       return
17707       end subroutine check_energies
17708 !-----------------------------------------------------------------------------
17709       subroutine dyn_ssbond_ene(resi,resj,eij)
17710 !      implicit none
17711 !      Includes
17712       use calc_data
17713       use comm_sschecks
17714 !      include 'DIMENSIONS'
17715 !      include 'COMMON.SBRIDGE'
17716 !      include 'COMMON.CHAIN'
17717 !      include 'COMMON.DERIV'
17718 !      include 'COMMON.LOCAL'
17719 !      include 'COMMON.INTERACT'
17720 !      include 'COMMON.VAR'
17721 !      include 'COMMON.IOUNITS'
17722 !      include 'COMMON.CALC'
17723 #ifndef CLUST
17724 #ifndef WHAM
17725        use MD_data
17726 !      include 'COMMON.MD'
17727 !      use MD, only: totT,t_bath
17728 #endif
17729 #endif
17730 !     External functions
17731 !EL      double precision h_base
17732 !EL      external h_base
17733
17734 !     Input arguments
17735       integer :: resi,resj
17736
17737 !     Output arguments
17738       real(kind=8) :: eij
17739
17740 !     Local variables
17741       logical :: havebond
17742       integer itypi,itypj
17743       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17744       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17745       real(kind=8),dimension(3) :: dcosom1,dcosom2
17746       real(kind=8) :: ed
17747       real(kind=8) :: pom1,pom2
17748       real(kind=8) :: ljA,ljB,ljXs
17749       real(kind=8),dimension(1:3) :: d_ljB
17750       real(kind=8) :: ssA,ssB,ssC,ssXs
17751       real(kind=8) :: ssxm,ljxm,ssm,ljm
17752       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17753       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17754       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17755 !-------FIRST METHOD
17756       real(kind=8) :: xm
17757       real(kind=8),dimension(1:3) :: d_xm
17758 !-------END FIRST METHOD
17759 !-------SECOND METHOD
17760 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17761 !-------END SECOND METHOD
17762
17763 !-------TESTING CODE
17764 !el      logical :: checkstop,transgrad
17765 !el      common /sschecks/ checkstop,transgrad
17766
17767       integer :: icheck,nicheck,jcheck,njcheck
17768       real(kind=8),dimension(-1:1) :: echeck
17769       real(kind=8) :: deps,ssx0,ljx0
17770 !-------END TESTING CODE
17771
17772       eij=0.0d0
17773       i=resi
17774       j=resj
17775
17776 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17777 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17778
17779       itypi=itype(i,1)
17780       dxi=dc_norm(1,nres+i)
17781       dyi=dc_norm(2,nres+i)
17782       dzi=dc_norm(3,nres+i)
17783       dsci_inv=vbld_inv(i+nres)
17784
17785       itypj=itype(j,1)
17786       xj=c(1,nres+j)-c(1,nres+i)
17787       yj=c(2,nres+j)-c(2,nres+i)
17788       zj=c(3,nres+j)-c(3,nres+i)
17789       dxj=dc_norm(1,nres+j)
17790       dyj=dc_norm(2,nres+j)
17791       dzj=dc_norm(3,nres+j)
17792       dscj_inv=vbld_inv(j+nres)
17793
17794       chi1=chi(itypi,itypj)
17795       chi2=chi(itypj,itypi)
17796       chi12=chi1*chi2
17797       chip1=chip(itypi)
17798       chip2=chip(itypj)
17799       chip12=chip1*chip2
17800       alf1=alp(itypi)
17801       alf2=alp(itypj)
17802       alf12=0.5D0*(alf1+alf2)
17803
17804       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17805       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17806 !     The following are set in sc_angular
17807 !      erij(1)=xj*rij
17808 !      erij(2)=yj*rij
17809 !      erij(3)=zj*rij
17810 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17811 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17812 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17813       call sc_angular
17814       rij=1.0D0/rij  ! Reset this so it makes sense
17815
17816       sig0ij=sigma(itypi,itypj)
17817       sig=sig0ij*dsqrt(1.0D0/sigsq)
17818
17819       ljXs=sig-sig0ij
17820       ljA=eps1*eps2rt**2*eps3rt**2
17821       ljB=ljA*bb_aq(itypi,itypj)
17822       ljA=ljA*aa_aq(itypi,itypj)
17823       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17824
17825       ssXs=d0cm
17826       deltat1=1.0d0-om1
17827       deltat2=1.0d0+om2
17828       deltat12=om2-om1+2.0d0
17829       cosphi=om12-om1*om2
17830       ssA=akcm
17831       ssB=akct*deltat12
17832       ssC=ss_depth &
17833            +akth*(deltat1*deltat1+deltat2*deltat2) &
17834            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17835       ssxm=ssXs-0.5D0*ssB/ssA
17836
17837 !-------TESTING CODE
17838 !$$$c     Some extra output
17839 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17840 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17841 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17842 !$$$      if (ssx0.gt.0.0d0) then
17843 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17844 !$$$      else
17845 !$$$        ssx0=ssxm
17846 !$$$      endif
17847 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17848 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17849 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17850 !$$$      return
17851 !-------END TESTING CODE
17852
17853 !-------TESTING CODE
17854 !     Stop and plot energy and derivative as a function of distance
17855       if (checkstop) then
17856         ssm=ssC-0.25D0*ssB*ssB/ssA
17857         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17858         if (ssm.lt.ljm .and. &
17859              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17860           nicheck=1000
17861           njcheck=1
17862           deps=0.5d-7
17863         else
17864           checkstop=.false.
17865         endif
17866       endif
17867       if (.not.checkstop) then
17868         nicheck=0
17869         njcheck=-1
17870       endif
17871
17872       do icheck=0,nicheck
17873       do jcheck=-1,njcheck
17874       if (checkstop) rij=(ssxm-1.0d0)+ &
17875              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17876 !-------END TESTING CODE
17877
17878       if (rij.gt.ljxm) then
17879         havebond=.false.
17880         ljd=rij-ljXs
17881         fac=(1.0D0/ljd)**expon
17882         e1=fac*fac*aa_aq(itypi,itypj)
17883         e2=fac*bb_aq(itypi,itypj)
17884         eij=eps1*eps2rt*eps3rt*(e1+e2)
17885         eps2der=eij*eps3rt
17886         eps3der=eij*eps2rt
17887         eij=eij*eps2rt*eps3rt
17888
17889         sigder=-sig/sigsq
17890         e1=e1*eps1*eps2rt**2*eps3rt**2
17891         ed=-expon*(e1+eij)/ljd
17892         sigder=ed*sigder
17893         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17894         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17895         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
17896              -2.0D0*alf12*eps3der+sigder*sigsq_om12
17897       else if (rij.lt.ssxm) then
17898         havebond=.true.
17899         ssd=rij-ssXs
17900         eij=ssA*ssd*ssd+ssB*ssd+ssC
17901
17902         ed=2*akcm*ssd+akct*deltat12
17903         pom1=akct*ssd
17904         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
17905         eom1=-2*akth*deltat1-pom1-om2*pom2
17906         eom2= 2*akth*deltat2+pom1-om1*pom2
17907         eom12=pom2
17908       else
17909         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
17910
17911         d_ssxm(1)=0.5D0*akct/ssA
17912         d_ssxm(2)=-d_ssxm(1)
17913         d_ssxm(3)=0.0D0
17914
17915         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
17916         d_ljxm(2)=d_ljxm(1)*sigsq_om2
17917         d_ljxm(3)=d_ljxm(1)*sigsq_om12
17918         d_ljxm(1)=d_ljxm(1)*sigsq_om1
17919
17920 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17921         xm=0.5d0*(ssxm+ljxm)
17922         do k=1,3
17923           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
17924         enddo
17925         if (rij.lt.xm) then
17926           havebond=.true.
17927           ssm=ssC-0.25D0*ssB*ssB/ssA
17928           d_ssm(1)=0.5D0*akct*ssB/ssA
17929           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17930           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17931           d_ssm(3)=omega
17932           f1=(rij-xm)/(ssxm-xm)
17933           f2=(rij-ssxm)/(xm-ssxm)
17934           h1=h_base(f1,hd1)
17935           h2=h_base(f2,hd2)
17936           eij=ssm*h1+Ht*h2
17937           delta_inv=1.0d0/(xm-ssxm)
17938           deltasq_inv=delta_inv*delta_inv
17939           fac=ssm*hd1-Ht*hd2
17940           fac1=deltasq_inv*fac*(xm-rij)
17941           fac2=deltasq_inv*fac*(rij-ssxm)
17942           ed=delta_inv*(Ht*hd2-ssm*hd1)
17943           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
17944           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
17945           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
17946         else
17947           havebond=.false.
17948           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17949           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
17950           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
17951           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
17952                alf12/eps3rt)
17953           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
17954           f1=(rij-ljxm)/(xm-ljxm)
17955           f2=(rij-xm)/(ljxm-xm)
17956           h1=h_base(f1,hd1)
17957           h2=h_base(f2,hd2)
17958           eij=Ht*h1+ljm*h2
17959           delta_inv=1.0d0/(ljxm-xm)
17960           deltasq_inv=delta_inv*delta_inv
17961           fac=Ht*hd1-ljm*hd2
17962           fac1=deltasq_inv*fac*(ljxm-rij)
17963           fac2=deltasq_inv*fac*(rij-xm)
17964           ed=delta_inv*(ljm*hd2-Ht*hd1)
17965           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
17966           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
17967           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
17968         endif
17969 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17970
17971 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17972 !$$$        ssd=rij-ssXs
17973 !$$$        ljd=rij-ljXs
17974 !$$$        fac1=rij-ljxm
17975 !$$$        fac2=rij-ssxm
17976 !$$$
17977 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
17978 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
17979 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
17980 !$$$
17981 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
17982 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
17983 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17984 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17985 !$$$        d_ssm(3)=omega
17986 !$$$
17987 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
17988 !$$$        do k=1,3
17989 !$$$          d_ljm(k)=ljm*d_ljB(k)
17990 !$$$        enddo
17991 !$$$        ljm=ljm*ljB
17992 !$$$
17993 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
17994 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
17995 !$$$        d_ss(2)=akct*ssd
17996 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
17997 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
17998 !$$$        d_ss(3)=omega
17999 !$$$
18000 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18001 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18002 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18003 !$$$        do k=1,3
18004 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18005 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18006 !$$$        enddo
18007 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18008 !$$$
18009 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18010 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18011 !$$$        h1=h_base(f1,hd1)
18012 !$$$        h2=h_base(f2,hd2)
18013 !$$$        eij=ss*h1+ljf*h2
18014 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18015 !$$$        deltasq_inv=delta_inv*delta_inv
18016 !$$$        fac=ljf*hd2-ss*hd1
18017 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18018 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18019 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18020 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18021 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18022 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18023 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18024 !$$$
18025 !$$$        havebond=.false.
18026 !$$$        if (ed.gt.0.0d0) havebond=.true.
18027 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18028
18029       endif
18030
18031       if (havebond) then
18032 !#ifndef CLUST
18033 !#ifndef WHAM
18034 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18035 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18036 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18037 !        endif
18038 !#endif
18039 !#endif
18040         dyn_ssbond_ij(i,j)=eij
18041       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18042         dyn_ssbond_ij(i,j)=1.0d300
18043 !#ifndef CLUST
18044 !#ifndef WHAM
18045 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18046 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18047 !#endif
18048 !#endif
18049       endif
18050
18051 !-------TESTING CODE
18052 !el      if (checkstop) then
18053         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18054              "CHECKSTOP",rij,eij,ed
18055         echeck(jcheck)=eij
18056 !el      endif
18057       enddo
18058       if (checkstop) then
18059         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18060       endif
18061       enddo
18062       if (checkstop) then
18063         transgrad=.true.
18064         checkstop=.false.
18065       endif
18066 !-------END TESTING CODE
18067
18068       do k=1,3
18069         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18070         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18071       enddo
18072       do k=1,3
18073         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18074       enddo
18075       do k=1,3
18076         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18077              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18078              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18079         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18080              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18081              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18082       enddo
18083 !grad      do k=i,j-1
18084 !grad        do l=1,3
18085 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18086 !grad        enddo
18087 !grad      enddo
18088
18089       do l=1,3
18090         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18091         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18092       enddo
18093
18094       return
18095       end subroutine dyn_ssbond_ene
18096 !--------------------------------------------------------------------------
18097          subroutine triple_ssbond_ene(resi,resj,resk,eij)
18098 !      implicit none
18099 !      Includes
18100       use calc_data
18101       use comm_sschecks
18102 !      include 'DIMENSIONS'
18103 !      include 'COMMON.SBRIDGE'
18104 !      include 'COMMON.CHAIN'
18105 !      include 'COMMON.DERIV'
18106 !      include 'COMMON.LOCAL'
18107 !      include 'COMMON.INTERACT'
18108 !      include 'COMMON.VAR'
18109 !      include 'COMMON.IOUNITS'
18110 !      include 'COMMON.CALC'
18111 #ifndef CLUST
18112 #ifndef WHAM
18113        use MD_data
18114 !      include 'COMMON.MD'
18115 !      use MD, only: totT,t_bath
18116 #endif
18117 #endif
18118       double precision h_base
18119       external h_base
18120
18121 !c     Input arguments
18122       integer resi,resj,resk,m,itypi,itypj,itypk
18123
18124 !c     Output arguments
18125       double precision eij,eij1,eij2,eij3
18126
18127 !c     Local variables
18128       logical havebond
18129 !c      integer itypi,itypj,k,l
18130       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18131       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18132       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18133       double precision sig0ij,ljd,sig,fac,e1,e2
18134       double precision dcosom1(3),dcosom2(3),ed
18135       double precision pom1,pom2
18136       double precision ljA,ljB,ljXs
18137       double precision d_ljB(1:3)
18138       double precision ssA,ssB,ssC,ssXs
18139       double precision ssxm,ljxm,ssm,ljm
18140       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18141       eij=0.0
18142       if (dtriss.eq.0) return
18143       i=resi
18144       j=resj
18145       k=resk
18146 !C      write(iout,*) resi,resj,resk
18147       itypi=itype(i,1)
18148       dxi=dc_norm(1,nres+i)
18149       dyi=dc_norm(2,nres+i)
18150       dzi=dc_norm(3,nres+i)
18151       dsci_inv=vbld_inv(i+nres)
18152       xi=c(1,nres+i)
18153       yi=c(2,nres+i)
18154       zi=c(3,nres+i)
18155       itypj=itype(j,1)
18156       xj=c(1,nres+j)
18157       yj=c(2,nres+j)
18158       zj=c(3,nres+j)
18159
18160       dxj=dc_norm(1,nres+j)
18161       dyj=dc_norm(2,nres+j)
18162       dzj=dc_norm(3,nres+j)
18163       dscj_inv=vbld_inv(j+nres)
18164       itypk=itype(k,1)
18165       xk=c(1,nres+k)
18166       yk=c(2,nres+k)
18167       zk=c(3,nres+k)
18168
18169       dxk=dc_norm(1,nres+k)
18170       dyk=dc_norm(2,nres+k)
18171       dzk=dc_norm(3,nres+k)
18172       dscj_inv=vbld_inv(k+nres)
18173       xij=xj-xi
18174       xik=xk-xi
18175       xjk=xk-xj
18176       yij=yj-yi
18177       yik=yk-yi
18178       yjk=yk-yj
18179       zij=zj-zi
18180       zik=zk-zi
18181       zjk=zk-zj
18182       rrij=(xij*xij+yij*yij+zij*zij)
18183       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18184       rrik=(xik*xik+yik*yik+zik*zik)
18185       rik=dsqrt(rrik)
18186       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18187       rjk=dsqrt(rrjk)
18188 !C there are three combination of distances for each trisulfide bonds
18189 !C The first case the ith atom is the center
18190 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18191 !C distance y is second distance the a,b,c,d are parameters derived for
18192 !C this problem d parameter was set as a penalty currenlty set to 1.
18193       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18194       eij1=0.0d0
18195       else
18196       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18197       endif
18198 !C second case jth atom is center
18199       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18200       eij2=0.0d0
18201       else
18202       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18203       endif
18204 !C the third case kth atom is the center
18205       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18206       eij3=0.0d0
18207       else
18208       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18209       endif
18210 !C      eij2=0.0
18211 !C      eij3=0.0
18212 !C      eij1=0.0
18213       eij=eij1+eij2+eij3
18214 !C      write(iout,*)i,j,k,eij
18215 !C The energy penalty calculated now time for the gradient part
18216 !C derivative over rij
18217       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18218       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18219             gg(1)=xij*fac/rij
18220             gg(2)=yij*fac/rij
18221             gg(3)=zij*fac/rij
18222       do m=1,3
18223         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18224         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18225       enddo
18226
18227       do l=1,3
18228         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18229         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18230       enddo
18231 !C now derivative over rik
18232       fac=-eij1**2/dtriss* &
18233       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18234       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18235             gg(1)=xik*fac/rik
18236             gg(2)=yik*fac/rik
18237             gg(3)=zik*fac/rik
18238       do m=1,3
18239         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18240         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18241       enddo
18242       do l=1,3
18243         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18244         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18245       enddo
18246 !C now derivative over rjk
18247       fac=-eij2**2/dtriss* &
18248       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18249       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18250             gg(1)=xjk*fac/rjk
18251             gg(2)=yjk*fac/rjk
18252             gg(3)=zjk*fac/rjk
18253       do m=1,3
18254         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18255         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18256       enddo
18257       do l=1,3
18258         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18259         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18260       enddo
18261       return
18262       end subroutine triple_ssbond_ene
18263
18264
18265
18266 !-----------------------------------------------------------------------------
18267       real(kind=8) function h_base(x,deriv)
18268 !     A smooth function going 0->1 in range [0,1]
18269 !     It should NOT be called outside range [0,1], it will not work there.
18270       implicit none
18271
18272 !     Input arguments
18273       real(kind=8) :: x
18274
18275 !     Output arguments
18276       real(kind=8) :: deriv
18277
18278 !     Local variables
18279       real(kind=8) :: xsq
18280
18281
18282 !     Two parabolas put together.  First derivative zero at extrema
18283 !$$$      if (x.lt.0.5D0) then
18284 !$$$        h_base=2.0D0*x*x
18285 !$$$        deriv=4.0D0*x
18286 !$$$      else
18287 !$$$        deriv=1.0D0-x
18288 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18289 !$$$        deriv=4.0D0*deriv
18290 !$$$      endif
18291
18292 !     Third degree polynomial.  First derivative zero at extrema
18293       h_base=x*x*(3.0d0-2.0d0*x)
18294       deriv=6.0d0*x*(1.0d0-x)
18295
18296 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18297 !$$$      xsq=x*x
18298 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18299 !$$$      deriv=x-1.0d0
18300 !$$$      deriv=deriv*deriv
18301 !$$$      deriv=30.0d0*xsq*deriv
18302
18303       return
18304       end function h_base
18305 !-----------------------------------------------------------------------------
18306       subroutine dyn_set_nss
18307 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18308 !      implicit none
18309       use MD_data, only: totT,t_bath
18310 !     Includes
18311 !      include 'DIMENSIONS'
18312 #ifdef MPI
18313       include "mpif.h"
18314 #endif
18315 !      include 'COMMON.SBRIDGE'
18316 !      include 'COMMON.CHAIN'
18317 !      include 'COMMON.IOUNITS'
18318 !      include 'COMMON.SETUP'
18319 !      include 'COMMON.MD'
18320 !     Local variables
18321       real(kind=8) :: emin
18322       integer :: i,j,imin,ierr
18323       integer :: diff,allnss,newnss
18324       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18325                 newihpb,newjhpb
18326       logical :: found
18327       integer,dimension(0:nfgtasks) :: i_newnss
18328       integer,dimension(0:nfgtasks) :: displ
18329       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18330       integer :: g_newnss
18331
18332       allnss=0
18333       do i=1,nres-1
18334         do j=i+1,nres
18335           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18336             allnss=allnss+1
18337             allflag(allnss)=0
18338             allihpb(allnss)=i
18339             alljhpb(allnss)=j
18340           endif
18341         enddo
18342       enddo
18343
18344 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18345
18346  1    emin=1.0d300
18347       do i=1,allnss
18348         if (allflag(i).eq.0 .and. &
18349              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18350           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18351           imin=i
18352         endif
18353       enddo
18354       if (emin.lt.1.0d300) then
18355         allflag(imin)=1
18356         do i=1,allnss
18357           if (allflag(i).eq.0 .and. &
18358                (allihpb(i).eq.allihpb(imin) .or. &
18359                alljhpb(i).eq.allihpb(imin) .or. &
18360                allihpb(i).eq.alljhpb(imin) .or. &
18361                alljhpb(i).eq.alljhpb(imin))) then
18362             allflag(i)=-1
18363           endif
18364         enddo
18365         goto 1
18366       endif
18367
18368 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18369
18370       newnss=0
18371       do i=1,allnss
18372         if (allflag(i).eq.1) then
18373           newnss=newnss+1
18374           newihpb(newnss)=allihpb(i)
18375           newjhpb(newnss)=alljhpb(i)
18376         endif
18377       enddo
18378
18379 #ifdef MPI
18380       if (nfgtasks.gt.1)then
18381
18382         call MPI_Reduce(newnss,g_newnss,1,&
18383           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18384         call MPI_Gather(newnss,1,MPI_INTEGER,&
18385                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18386         displ(0)=0
18387         do i=1,nfgtasks-1,1
18388           displ(i)=i_newnss(i-1)+displ(i-1)
18389         enddo
18390         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18391                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18392                          king,FG_COMM,IERR)
18393         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18394                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18395                          king,FG_COMM,IERR)
18396         if(fg_rank.eq.0) then
18397 !         print *,'g_newnss',g_newnss
18398 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18399 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18400          newnss=g_newnss
18401          do i=1,newnss
18402           newihpb(i)=g_newihpb(i)
18403           newjhpb(i)=g_newjhpb(i)
18404          enddo
18405         endif
18406       endif
18407 #endif
18408
18409       diff=newnss-nss
18410
18411 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18412 !       print *,newnss,nss,maxdim
18413       do i=1,nss
18414         found=.false.
18415 !        print *,newnss
18416         do j=1,newnss
18417 !!          print *,j
18418           if (idssb(i).eq.newihpb(j) .and. &
18419                jdssb(i).eq.newjhpb(j)) found=.true.
18420         enddo
18421 #ifndef CLUST
18422 #ifndef WHAM
18423 !        write(iout,*) "found",found,i,j
18424         if (.not.found.and.fg_rank.eq.0) &
18425             write(iout,'(a15,f12.2,f8.1,2i5)') &
18426              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18427 #endif
18428 #endif
18429       enddo
18430
18431       do i=1,newnss
18432         found=.false.
18433         do j=1,nss
18434 !          print *,i,j
18435           if (newihpb(i).eq.idssb(j) .and. &
18436                newjhpb(i).eq.jdssb(j)) found=.true.
18437         enddo
18438 #ifndef CLUST
18439 #ifndef WHAM
18440 !        write(iout,*) "found",found,i,j
18441         if (.not.found.and.fg_rank.eq.0) &
18442             write(iout,'(a15,f12.2,f8.1,2i5)') &
18443              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18444 #endif
18445 #endif
18446       enddo
18447
18448       nss=newnss
18449       do i=1,nss
18450         idssb(i)=newihpb(i)
18451         jdssb(i)=newjhpb(i)
18452       enddo
18453
18454       return
18455       end subroutine dyn_set_nss
18456 ! Lipid transfer energy function
18457       subroutine Eliptransfer(eliptran)
18458 !C this is done by Adasko
18459 !C      print *,"wchodze"
18460 !C structure of box:
18461 !C      water
18462 !C--bordliptop-- buffore starts
18463 !C--bufliptop--- here true lipid starts
18464 !C      lipid
18465 !C--buflipbot--- lipid ends buffore starts
18466 !C--bordlipbot--buffore ends
18467       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18468       integer :: i
18469       eliptran=0.0
18470 !      print *, "I am in eliptran"
18471       do i=ilip_start,ilip_end
18472 !C       do i=1,1
18473         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18474          cycle
18475
18476         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18477         if (positi.le.0.0) positi=positi+boxzsize
18478 !C        print *,i
18479 !C first for peptide groups
18480 !c for each residue check if it is in lipid or lipid water border area
18481        if ((positi.gt.bordlipbot)  &
18482       .and.(positi.lt.bordliptop)) then
18483 !C the energy transfer exist
18484         if (positi.lt.buflipbot) then
18485 !C what fraction I am in
18486          fracinbuf=1.0d0-      &
18487              ((positi-bordlipbot)/lipbufthick)
18488 !C lipbufthick is thickenes of lipid buffore
18489          sslip=sscalelip(fracinbuf)
18490          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18491          eliptran=eliptran+sslip*pepliptran
18492          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18493          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18494 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18495
18496 !C        print *,"doing sccale for lower part"
18497 !C         print *,i,sslip,fracinbuf,ssgradlip
18498         elseif (positi.gt.bufliptop) then
18499          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18500          sslip=sscalelip(fracinbuf)
18501          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18502          eliptran=eliptran+sslip*pepliptran
18503          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18504          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18505 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18506 !C          print *, "doing sscalefor top part"
18507 !C         print *,i,sslip,fracinbuf,ssgradlip
18508         else
18509          eliptran=eliptran+pepliptran
18510 !C         print *,"I am in true lipid"
18511         endif
18512 !C       else
18513 !C       eliptran=elpitran+0.0 ! I am in water
18514        endif
18515        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18516        enddo
18517 ! here starts the side chain transfer
18518        do i=ilip_start,ilip_end
18519         if (itype(i,1).eq.ntyp1) cycle
18520         positi=(mod(c(3,i+nres),boxzsize))
18521         if (positi.le.0) positi=positi+boxzsize
18522 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18523 !c for each residue check if it is in lipid or lipid water border area
18524 !C       respos=mod(c(3,i+nres),boxzsize)
18525 !C       print *,positi,bordlipbot,buflipbot
18526        if ((positi.gt.bordlipbot) &
18527        .and.(positi.lt.bordliptop)) then
18528 !C the energy transfer exist
18529         if (positi.lt.buflipbot) then
18530          fracinbuf=1.0d0-   &
18531            ((positi-bordlipbot)/lipbufthick)
18532 !C lipbufthick is thickenes of lipid buffore
18533          sslip=sscalelip(fracinbuf)
18534          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18535          eliptran=eliptran+sslip*liptranene(itype(i,1))
18536          gliptranx(3,i)=gliptranx(3,i) &
18537       +ssgradlip*liptranene(itype(i,1))
18538          gliptranc(3,i-1)= gliptranc(3,i-1) &
18539       +ssgradlip*liptranene(itype(i,1))
18540 !C         print *,"doing sccale for lower part"
18541         elseif (positi.gt.bufliptop) then
18542          fracinbuf=1.0d0-  &
18543       ((bordliptop-positi)/lipbufthick)
18544          sslip=sscalelip(fracinbuf)
18545          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18546          eliptran=eliptran+sslip*liptranene(itype(i,1))
18547          gliptranx(3,i)=gliptranx(3,i)  &
18548        +ssgradlip*liptranene(itype(i,1))
18549          gliptranc(3,i-1)= gliptranc(3,i-1) &
18550       +ssgradlip*liptranene(itype(i,1))
18551 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18552         else
18553          eliptran=eliptran+liptranene(itype(i,1))
18554 !C         print *,"I am in true lipid"
18555         endif
18556         endif ! if in lipid or buffor
18557 !C       else
18558 !C       eliptran=elpitran+0.0 ! I am in water
18559         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18560        enddo
18561        return
18562        end  subroutine Eliptransfer
18563 !----------------------------------NANO FUNCTIONS
18564 !C-----------------------------------------------------------------------
18565 !C-----------------------------------------------------------
18566 !C This subroutine is to mimic the histone like structure but as well can be
18567 !C utilizet to nanostructures (infinit) small modification has to be used to
18568 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18569 !C gradient has to be modified at the ends
18570 !C The energy function is Kihara potential
18571 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18572 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18573 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18574 !C simple Kihara potential
18575       subroutine calctube(Etube)
18576       real(kind=8),dimension(3) :: vectube
18577       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18578        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18579        sc_aa_tube,sc_bb_tube
18580       integer :: i,j,iti
18581       Etube=0.0d0
18582       do i=itube_start,itube_end
18583         enetube(i)=0.0d0
18584         enetube(i+nres)=0.0d0
18585       enddo
18586 !C first we calculate the distance from tube center
18587 !C for UNRES
18588        do i=itube_start,itube_end
18589 !C lets ommit dummy atoms for now
18590        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18591 !C now calculate distance from center of tube and direction vectors
18592       xmin=boxxsize
18593       ymin=boxysize
18594 ! Find minimum distance in periodic box
18595         do j=-1,1
18596          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18597          vectube(1)=vectube(1)+boxxsize*j
18598          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18599          vectube(2)=vectube(2)+boxysize*j
18600          xminact=abs(vectube(1)-tubecenter(1))
18601          yminact=abs(vectube(2)-tubecenter(2))
18602            if (xmin.gt.xminact) then
18603             xmin=xminact
18604             xtemp=vectube(1)
18605            endif
18606            if (ymin.gt.yminact) then
18607              ymin=yminact
18608              ytemp=vectube(2)
18609             endif
18610          enddo
18611       vectube(1)=xtemp
18612       vectube(2)=ytemp
18613       vectube(1)=vectube(1)-tubecenter(1)
18614       vectube(2)=vectube(2)-tubecenter(2)
18615
18616 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18617 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18618
18619 !C as the tube is infinity we do not calculate the Z-vector use of Z
18620 !C as chosen axis
18621       vectube(3)=0.0d0
18622 !C now calculte the distance
18623        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18624 !C now normalize vector
18625       vectube(1)=vectube(1)/tub_r
18626       vectube(2)=vectube(2)/tub_r
18627 !C calculte rdiffrence between r and r0
18628       rdiff=tub_r-tubeR0
18629 !C and its 6 power
18630       rdiff6=rdiff**6.0d0
18631 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18632        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18633 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18634 !C       print *,rdiff,rdiff6,pep_aa_tube
18635 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18636 !C now we calculate gradient
18637        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18638             6.0d0*pep_bb_tube)/rdiff6/rdiff
18639 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18640 !C     &rdiff,fac
18641 !C now direction of gg_tube vector
18642         do j=1,3
18643         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18644         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18645         enddo
18646         enddo
18647 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18648 !C        print *,gg_tube(1,0),"TU"
18649
18650
18651        do i=itube_start,itube_end
18652 !C Lets not jump over memory as we use many times iti
18653          iti=itype(i,1)
18654 !C lets ommit dummy atoms for now
18655          if ((iti.eq.ntyp1)  &
18656 !C in UNRES uncomment the line below as GLY has no side-chain...
18657 !C      .or.(iti.eq.10)
18658         ) cycle
18659       xmin=boxxsize
18660       ymin=boxysize
18661         do j=-1,1
18662          vectube(1)=mod((c(1,i+nres)),boxxsize)
18663          vectube(1)=vectube(1)+boxxsize*j
18664          vectube(2)=mod((c(2,i+nres)),boxysize)
18665          vectube(2)=vectube(2)+boxysize*j
18666
18667          xminact=abs(vectube(1)-tubecenter(1))
18668          yminact=abs(vectube(2)-tubecenter(2))
18669            if (xmin.gt.xminact) then
18670             xmin=xminact
18671             xtemp=vectube(1)
18672            endif
18673            if (ymin.gt.yminact) then
18674              ymin=yminact
18675              ytemp=vectube(2)
18676             endif
18677          enddo
18678       vectube(1)=xtemp
18679       vectube(2)=ytemp
18680 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18681 !C     &     tubecenter(2)
18682       vectube(1)=vectube(1)-tubecenter(1)
18683       vectube(2)=vectube(2)-tubecenter(2)
18684
18685 !C as the tube is infinity we do not calculate the Z-vector use of Z
18686 !C as chosen axis
18687       vectube(3)=0.0d0
18688 !C now calculte the distance
18689        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18690 !C now normalize vector
18691       vectube(1)=vectube(1)/tub_r
18692       vectube(2)=vectube(2)/tub_r
18693
18694 !C calculte rdiffrence between r and r0
18695       rdiff=tub_r-tubeR0
18696 !C and its 6 power
18697       rdiff6=rdiff**6.0d0
18698 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18699        sc_aa_tube=sc_aa_tube_par(iti)
18700        sc_bb_tube=sc_bb_tube_par(iti)
18701        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18702        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18703              6.0d0*sc_bb_tube/rdiff6/rdiff
18704 !C now direction of gg_tube vector
18705          do j=1,3
18706           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18707           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18708          enddo
18709         enddo
18710         do i=itube_start,itube_end
18711           Etube=Etube+enetube(i)+enetube(i+nres)
18712         enddo
18713 !C        print *,"ETUBE", etube
18714         return
18715         end subroutine calctube
18716 !C TO DO 1) add to total energy
18717 !C       2) add to gradient summation
18718 !C       3) add reading parameters (AND of course oppening of PARAM file)
18719 !C       4) add reading the center of tube
18720 !C       5) add COMMONs
18721 !C       6) add to zerograd
18722 !C       7) allocate matrices
18723
18724
18725 !C-----------------------------------------------------------------------
18726 !C-----------------------------------------------------------
18727 !C This subroutine is to mimic the histone like structure but as well can be
18728 !C utilizet to nanostructures (infinit) small modification has to be used to
18729 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18730 !C gradient has to be modified at the ends
18731 !C The energy function is Kihara potential
18732 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18733 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18734 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18735 !C simple Kihara potential
18736       subroutine calctube2(Etube)
18737             real(kind=8),dimension(3) :: vectube
18738       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18739        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18740        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18741       integer:: i,j,iti
18742       Etube=0.0d0
18743       do i=itube_start,itube_end
18744         enetube(i)=0.0d0
18745         enetube(i+nres)=0.0d0
18746       enddo
18747 !C first we calculate the distance from tube center
18748 !C first sugare-phosphate group for NARES this would be peptide group
18749 !C for UNRES
18750        do i=itube_start,itube_end
18751 !C lets ommit dummy atoms for now
18752
18753        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18754 !C now calculate distance from center of tube and direction vectors
18755 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18756 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18757 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18758 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18759       xmin=boxxsize
18760       ymin=boxysize
18761         do j=-1,1
18762          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18763          vectube(1)=vectube(1)+boxxsize*j
18764          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18765          vectube(2)=vectube(2)+boxysize*j
18766
18767          xminact=abs(vectube(1)-tubecenter(1))
18768          yminact=abs(vectube(2)-tubecenter(2))
18769            if (xmin.gt.xminact) then
18770             xmin=xminact
18771             xtemp=vectube(1)
18772            endif
18773            if (ymin.gt.yminact) then
18774              ymin=yminact
18775              ytemp=vectube(2)
18776             endif
18777          enddo
18778       vectube(1)=xtemp
18779       vectube(2)=ytemp
18780       vectube(1)=vectube(1)-tubecenter(1)
18781       vectube(2)=vectube(2)-tubecenter(2)
18782
18783 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18784 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18785
18786 !C as the tube is infinity we do not calculate the Z-vector use of Z
18787 !C as chosen axis
18788       vectube(3)=0.0d0
18789 !C now calculte the distance
18790        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18791 !C now normalize vector
18792       vectube(1)=vectube(1)/tub_r
18793       vectube(2)=vectube(2)/tub_r
18794 !C calculte rdiffrence between r and r0
18795       rdiff=tub_r-tubeR0
18796 !C and its 6 power
18797       rdiff6=rdiff**6.0d0
18798 !C THIS FRAGMENT MAKES TUBE FINITE
18799         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18800         if (positi.le.0) positi=positi+boxzsize
18801 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18802 !c for each residue check if it is in lipid or lipid water border area
18803 !C       respos=mod(c(3,i+nres),boxzsize)
18804 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18805        if ((positi.gt.bordtubebot)  &
18806         .and.(positi.lt.bordtubetop)) then
18807 !C the energy transfer exist
18808         if (positi.lt.buftubebot) then
18809          fracinbuf=1.0d0-  &
18810            ((positi-bordtubebot)/tubebufthick)
18811 !C lipbufthick is thickenes of lipid buffore
18812          sstube=sscalelip(fracinbuf)
18813          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18814 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18815          enetube(i)=enetube(i)+sstube*tubetranenepep
18816 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18817 !C     &+ssgradtube*tubetranene(itype(i,1))
18818 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18819 !C     &+ssgradtube*tubetranene(itype(i,1))
18820 !C         print *,"doing sccale for lower part"
18821         elseif (positi.gt.buftubetop) then
18822          fracinbuf=1.0d0-  &
18823         ((bordtubetop-positi)/tubebufthick)
18824          sstube=sscalelip(fracinbuf)
18825          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18826          enetube(i)=enetube(i)+sstube*tubetranenepep
18827 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18828 !C     &+ssgradtube*tubetranene(itype(i,1))
18829 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18830 !C     &+ssgradtube*tubetranene(itype(i,1))
18831 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18832         else
18833          sstube=1.0d0
18834          ssgradtube=0.0d0
18835          enetube(i)=enetube(i)+sstube*tubetranenepep
18836 !C         print *,"I am in true lipid"
18837         endif
18838         else
18839 !C          sstube=0.0d0
18840 !C          ssgradtube=0.0d0
18841         cycle
18842         endif ! if in lipid or buffor
18843
18844 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18845        enetube(i)=enetube(i)+sstube* &
18846         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18847 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18848 !C       print *,rdiff,rdiff6,pep_aa_tube
18849 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18850 !C now we calculate gradient
18851        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18852              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18853 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18854 !C     &rdiff,fac
18855
18856 !C now direction of gg_tube vector
18857        do j=1,3
18858         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18859         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18860         enddo
18861          gg_tube(3,i)=gg_tube(3,i)  &
18862        +ssgradtube*enetube(i)/sstube/2.0d0
18863          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18864        +ssgradtube*enetube(i)/sstube/2.0d0
18865
18866         enddo
18867 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18868 !C        print *,gg_tube(1,0),"TU"
18869         do i=itube_start,itube_end
18870 !C Lets not jump over memory as we use many times iti
18871          iti=itype(i,1)
18872 !C lets ommit dummy atoms for now
18873          if ((iti.eq.ntyp1) &
18874 !!C in UNRES uncomment the line below as GLY has no side-chain...
18875            .or.(iti.eq.10) &
18876           ) cycle
18877           vectube(1)=c(1,i+nres)
18878           vectube(1)=mod(vectube(1),boxxsize)
18879           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18880           vectube(2)=c(2,i+nres)
18881           vectube(2)=mod(vectube(2),boxysize)
18882           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18883
18884       vectube(1)=vectube(1)-tubecenter(1)
18885       vectube(2)=vectube(2)-tubecenter(2)
18886 !C THIS FRAGMENT MAKES TUBE FINITE
18887         positi=(mod(c(3,i+nres),boxzsize))
18888         if (positi.le.0) positi=positi+boxzsize
18889 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18890 !c for each residue check if it is in lipid or lipid water border area
18891 !C       respos=mod(c(3,i+nres),boxzsize)
18892 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18893
18894        if ((positi.gt.bordtubebot)  &
18895         .and.(positi.lt.bordtubetop)) then
18896 !C the energy transfer exist
18897         if (positi.lt.buftubebot) then
18898          fracinbuf=1.0d0- &
18899             ((positi-bordtubebot)/tubebufthick)
18900 !C lipbufthick is thickenes of lipid buffore
18901          sstube=sscalelip(fracinbuf)
18902          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18903 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18904          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18905 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18906 !C     &+ssgradtube*tubetranene(itype(i,1))
18907 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18908 !C     &+ssgradtube*tubetranene(itype(i,1))
18909 !C         print *,"doing sccale for lower part"
18910         elseif (positi.gt.buftubetop) then
18911          fracinbuf=1.0d0- &
18912         ((bordtubetop-positi)/tubebufthick)
18913
18914          sstube=sscalelip(fracinbuf)
18915          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18916          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18917 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18918 !C     &+ssgradtube*tubetranene(itype(i,1))
18919 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18920 !C     &+ssgradtube*tubetranene(itype(i,1))
18921 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18922         else
18923          sstube=1.0d0
18924          ssgradtube=0.0d0
18925          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18926 !C         print *,"I am in true lipid"
18927         endif
18928         else
18929 !C          sstube=0.0d0
18930 !C          ssgradtube=0.0d0
18931         cycle
18932         endif ! if in lipid or buffor
18933 !CEND OF FINITE FRAGMENT
18934 !C as the tube is infinity we do not calculate the Z-vector use of Z
18935 !C as chosen axis
18936       vectube(3)=0.0d0
18937 !C now calculte the distance
18938        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18939 !C now normalize vector
18940       vectube(1)=vectube(1)/tub_r
18941       vectube(2)=vectube(2)/tub_r
18942 !C calculte rdiffrence between r and r0
18943       rdiff=tub_r-tubeR0
18944 !C and its 6 power
18945       rdiff6=rdiff**6.0d0
18946 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18947        sc_aa_tube=sc_aa_tube_par(iti)
18948        sc_bb_tube=sc_bb_tube_par(iti)
18949        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
18950                        *sstube+enetube(i+nres)
18951 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18952 !C now we calculate gradient
18953        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
18954             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
18955 !C now direction of gg_tube vector
18956          do j=1,3
18957           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18958           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18959          enddo
18960          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
18961        +ssgradtube*enetube(i+nres)/sstube
18962          gg_tube(3,i-1)= gg_tube(3,i-1) &
18963        +ssgradtube*enetube(i+nres)/sstube
18964
18965         enddo
18966         do i=itube_start,itube_end
18967           Etube=Etube+enetube(i)+enetube(i+nres)
18968         enddo
18969 !C        print *,"ETUBE", etube
18970         return
18971         end subroutine calctube2
18972 !=====================================================================================================================================
18973       subroutine calcnano(Etube)
18974       real(kind=8),dimension(3) :: vectube
18975
18976       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18977        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
18978        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
18979        integer:: i,j,iti,r
18980
18981       Etube=0.0d0
18982 !      print *,itube_start,itube_end,"poczatek"
18983       do i=itube_start,itube_end
18984         enetube(i)=0.0d0
18985         enetube(i+nres)=0.0d0
18986       enddo
18987 !C first we calculate the distance from tube center
18988 !C first sugare-phosphate group for NARES this would be peptide group
18989 !C for UNRES
18990        do i=itube_start,itube_end
18991 !C lets ommit dummy atoms for now
18992        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18993 !C now calculate distance from center of tube and direction vectors
18994       xmin=boxxsize
18995       ymin=boxysize
18996       zmin=boxzsize
18997
18998         do j=-1,1
18999          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19000          vectube(1)=vectube(1)+boxxsize*j
19001          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19002          vectube(2)=vectube(2)+boxysize*j
19003          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19004          vectube(3)=vectube(3)+boxzsize*j
19005
19006
19007          xminact=dabs(vectube(1)-tubecenter(1))
19008          yminact=dabs(vectube(2)-tubecenter(2))
19009          zminact=dabs(vectube(3)-tubecenter(3))
19010
19011            if (xmin.gt.xminact) then
19012             xmin=xminact
19013             xtemp=vectube(1)
19014            endif
19015            if (ymin.gt.yminact) then
19016              ymin=yminact
19017              ytemp=vectube(2)
19018             endif
19019            if (zmin.gt.zminact) then
19020              zmin=zminact
19021              ztemp=vectube(3)
19022             endif
19023          enddo
19024       vectube(1)=xtemp
19025       vectube(2)=ytemp
19026       vectube(3)=ztemp
19027
19028       vectube(1)=vectube(1)-tubecenter(1)
19029       vectube(2)=vectube(2)-tubecenter(2)
19030       vectube(3)=vectube(3)-tubecenter(3)
19031
19032 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19033 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19034 !C as the tube is infinity we do not calculate the Z-vector use of Z
19035 !C as chosen axis
19036 !C      vectube(3)=0.0d0
19037 !C now calculte the distance
19038        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19039 !C now normalize vector
19040       vectube(1)=vectube(1)/tub_r
19041       vectube(2)=vectube(2)/tub_r
19042       vectube(3)=vectube(3)/tub_r
19043 !C calculte rdiffrence between r and r0
19044       rdiff=tub_r-tubeR0
19045 !C and its 6 power
19046       rdiff6=rdiff**6.0d0
19047 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19048        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19049 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19050 !C       print *,rdiff,rdiff6,pep_aa_tube
19051 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19052 !C now we calculate gradient
19053        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19054             6.0d0*pep_bb_tube)/rdiff6/rdiff
19055 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19056 !C     &rdiff,fac
19057          if (acavtubpep.eq.0.0d0) then
19058 !C go to 667
19059          enecavtube(i)=0.0
19060          faccav=0.0
19061          else
19062          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19063          enecavtube(i)=  &
19064         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19065         /denominator
19066          enecavtube(i)=0.0
19067          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19068         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19069         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19070         /denominator**2.0d0
19071 !C         faccav=0.0
19072 !C         fac=fac+faccav
19073 !C 667     continue
19074          endif
19075           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19076         do j=1,3
19077         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19078         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19079         enddo
19080         enddo
19081
19082        do i=itube_start,itube_end
19083         enecavtube(i)=0.0d0
19084 !C Lets not jump over memory as we use many times iti
19085          iti=itype(i,1)
19086 !C lets ommit dummy atoms for now
19087          if ((iti.eq.ntyp1) &
19088 !C in UNRES uncomment the line below as GLY has no side-chain...
19089 !C      .or.(iti.eq.10)
19090          ) cycle
19091       xmin=boxxsize
19092       ymin=boxysize
19093       zmin=boxzsize
19094         do j=-1,1
19095          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19096          vectube(1)=vectube(1)+boxxsize*j
19097          vectube(2)=dmod((c(2,i+nres)),boxysize)
19098          vectube(2)=vectube(2)+boxysize*j
19099          vectube(3)=dmod((c(3,i+nres)),boxzsize)
19100          vectube(3)=vectube(3)+boxzsize*j
19101
19102
19103          xminact=dabs(vectube(1)-tubecenter(1))
19104          yminact=dabs(vectube(2)-tubecenter(2))
19105          zminact=dabs(vectube(3)-tubecenter(3))
19106
19107            if (xmin.gt.xminact) then
19108             xmin=xminact
19109             xtemp=vectube(1)
19110            endif
19111            if (ymin.gt.yminact) then
19112              ymin=yminact
19113              ytemp=vectube(2)
19114             endif
19115            if (zmin.gt.zminact) then
19116              zmin=zminact
19117              ztemp=vectube(3)
19118             endif
19119          enddo
19120       vectube(1)=xtemp
19121       vectube(2)=ytemp
19122       vectube(3)=ztemp
19123
19124 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19125 !C     &     tubecenter(2)
19126       vectube(1)=vectube(1)-tubecenter(1)
19127       vectube(2)=vectube(2)-tubecenter(2)
19128       vectube(3)=vectube(3)-tubecenter(3)
19129 !C now calculte the distance
19130        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19131 !C now normalize vector
19132       vectube(1)=vectube(1)/tub_r
19133       vectube(2)=vectube(2)/tub_r
19134       vectube(3)=vectube(3)/tub_r
19135
19136 !C calculte rdiffrence between r and r0
19137       rdiff=tub_r-tubeR0
19138 !C and its 6 power
19139       rdiff6=rdiff**6.0d0
19140        sc_aa_tube=sc_aa_tube_par(iti)
19141        sc_bb_tube=sc_bb_tube_par(iti)
19142        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19143 !C       enetube(i+nres)=0.0d0
19144 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19145 !C now we calculate gradient
19146        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19147             6.0d0*sc_bb_tube/rdiff6/rdiff
19148 !C       fac=0.0
19149 !C now direction of gg_tube vector
19150 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19151          if (acavtub(iti).eq.0.0d0) then
19152 !C go to 667
19153          enecavtube(i+nres)=0.0d0
19154          faccav=0.0d0
19155          else
19156          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19157          enecavtube(i+nres)=   &
19158         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19159         /denominator
19160 !C         enecavtube(i)=0.0
19161          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19162         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19163         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19164         /denominator**2.0d0
19165 !C         faccav=0.0
19166          fac=fac+faccav
19167 !C 667     continue
19168          endif
19169 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19170 !C     &   enecavtube(i),faccav
19171 !C         print *,"licz=",
19172 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19173 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19174          do j=1,3
19175           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19176           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19177          enddo
19178           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19179         enddo
19180
19181
19182
19183         do i=itube_start,itube_end
19184           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19185          +enecavtube(i+nres)
19186         enddo
19187 !        do i=1,20
19188 !         print *,"begin", i,"a"
19189 !         do r=1,10000
19190 !          rdiff=r/100.0d0
19191 !          rdiff6=rdiff**6.0d0
19192 !          sc_aa_tube=sc_aa_tube_par(i)
19193 !          sc_bb_tube=sc_bb_tube_par(i)
19194 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19195 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19196 !          enecavtube(i)=   &
19197 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19198 !         /denominator
19199
19200 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19201 !         enddo
19202 !         print *,"end",i,"a"
19203 !        enddo
19204 !C        print *,"ETUBE", etube
19205         return
19206         end subroutine calcnano
19207
19208 !===============================================
19209 !--------------------------------------------------------------------------------
19210 !C first for shielding is setting of function of side-chains
19211
19212        subroutine set_shield_fac2
19213        real(kind=8) :: div77_81=0.974996043d0, &
19214         div4_81=0.2222222222d0
19215        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19216          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19217          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19218          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19219 !C the vector between center of side_chain and peptide group
19220        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19221          pept_group,costhet_grad,cosphi_grad_long, &
19222          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19223          sh_frac_dist_grad,pep_side
19224         integer i,j,k
19225 !C      write(2,*) "ivec",ivec_start,ivec_end
19226       do i=1,nres
19227         fac_shield(i)=0.0d0
19228         do j=1,3
19229         grad_shield(j,i)=0.0d0
19230         enddo
19231       enddo
19232       do i=ivec_start,ivec_end
19233 !C      do i=1,nres-1
19234 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19235       ishield_list(i)=0
19236       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19237 !Cif there two consequtive dummy atoms there is no peptide group between them
19238 !C the line below has to be changed for FGPROC>1
19239       VolumeTotal=0.0
19240       do k=1,nres
19241        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19242        dist_pep_side=0.0
19243        dist_side_calf=0.0
19244        do j=1,3
19245 !C first lets set vector conecting the ithe side-chain with kth side-chain
19246       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19247 !C      pep_side(j)=2.0d0
19248 !C and vector conecting the side-chain with its proper calfa
19249       side_calf(j)=c(j,k+nres)-c(j,k)
19250 !C      side_calf(j)=2.0d0
19251       pept_group(j)=c(j,i)-c(j,i+1)
19252 !C lets have their lenght
19253       dist_pep_side=pep_side(j)**2+dist_pep_side
19254       dist_side_calf=dist_side_calf+side_calf(j)**2
19255       dist_pept_group=dist_pept_group+pept_group(j)**2
19256       enddo
19257        dist_pep_side=sqrt(dist_pep_side)
19258        dist_pept_group=sqrt(dist_pept_group)
19259        dist_side_calf=sqrt(dist_side_calf)
19260       do j=1,3
19261         pep_side_norm(j)=pep_side(j)/dist_pep_side
19262         side_calf_norm(j)=dist_side_calf
19263       enddo
19264 !C now sscale fraction
19265        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19266 !C       print *,buff_shield,"buff"
19267 !C now sscale
19268         if (sh_frac_dist.le.0.0) cycle
19269 !C        print *,ishield_list(i),i
19270 !C If we reach here it means that this side chain reaches the shielding sphere
19271 !C Lets add him to the list for gradient
19272         ishield_list(i)=ishield_list(i)+1
19273 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19274 !C this list is essential otherwise problem would be O3
19275         shield_list(ishield_list(i),i)=k
19276 !C Lets have the sscale value
19277         if (sh_frac_dist.gt.1.0) then
19278          scale_fac_dist=1.0d0
19279          do j=1,3
19280          sh_frac_dist_grad(j)=0.0d0
19281          enddo
19282         else
19283          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19284                         *(2.0d0*sh_frac_dist-3.0d0)
19285          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19286                        /dist_pep_side/buff_shield*0.5d0
19287          do j=1,3
19288          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19289 !C         sh_frac_dist_grad(j)=0.0d0
19290 !C         scale_fac_dist=1.0d0
19291 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19292 !C     &                    sh_frac_dist_grad(j)
19293          enddo
19294         endif
19295 !C this is what is now we have the distance scaling now volume...
19296       short=short_r_sidechain(itype(k,1))
19297       long=long_r_sidechain(itype(k,1))
19298       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19299       sinthet=short/dist_pep_side*costhet
19300 !C now costhet_grad
19301 !C       costhet=0.6d0
19302 !C       sinthet=0.8
19303        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19304 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19305 !C     &             -short/dist_pep_side**2/costhet)
19306 !C       costhet_fac=0.0d0
19307        do j=1,3
19308          costhet_grad(j)=costhet_fac*pep_side(j)
19309        enddo
19310 !C remember for the final gradient multiply costhet_grad(j)
19311 !C for side_chain by factor -2 !
19312 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19313 !C pep_side0pept_group is vector multiplication
19314       pep_side0pept_group=0.0d0
19315       do j=1,3
19316       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19317       enddo
19318       cosalfa=(pep_side0pept_group/ &
19319       (dist_pep_side*dist_side_calf))
19320       fac_alfa_sin=1.0d0-cosalfa**2
19321       fac_alfa_sin=dsqrt(fac_alfa_sin)
19322       rkprim=fac_alfa_sin*(long-short)+short
19323 !C      rkprim=short
19324
19325 !C now costhet_grad
19326        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19327 !C       cosphi=0.6
19328        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19329        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19330            dist_pep_side**2)
19331 !C       sinphi=0.8
19332        do j=1,3
19333          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19334       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19335       *(long-short)/fac_alfa_sin*cosalfa/ &
19336       ((dist_pep_side*dist_side_calf))* &
19337       ((side_calf(j))-cosalfa* &
19338       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19339 !C       cosphi_grad_long(j)=0.0d0
19340         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19341       *(long-short)/fac_alfa_sin*cosalfa &
19342       /((dist_pep_side*dist_side_calf))* &
19343       (pep_side(j)- &
19344       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19345 !C       cosphi_grad_loc(j)=0.0d0
19346        enddo
19347 !C      print *,sinphi,sinthet
19348       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19349      &                    /VSolvSphere_div
19350 !C     &                    *wshield
19351 !C now the gradient...
19352       do j=1,3
19353       grad_shield(j,i)=grad_shield(j,i) &
19354 !C gradient po skalowaniu
19355                      +(sh_frac_dist_grad(j)*VofOverlap &
19356 !C  gradient po costhet
19357             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19358         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19359             sinphi/sinthet*costhet*costhet_grad(j) &
19360            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19361         )*wshield
19362 !C grad_shield_side is Cbeta sidechain gradient
19363       grad_shield_side(j,ishield_list(i),i)=&
19364              (sh_frac_dist_grad(j)*-2.0d0&
19365              *VofOverlap&
19366             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19367        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19368             sinphi/sinthet*costhet*costhet_grad(j)&
19369            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19370             )*wshield
19371
19372        grad_shield_loc(j,ishield_list(i),i)=   &
19373             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19374       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19375             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19376              ))&
19377              *wshield
19378       enddo
19379       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19380       enddo
19381       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19382
19383 !C      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19384       enddo
19385       return
19386       end subroutine set_shield_fac2
19387 !----------------------------------------------------------------------------
19388 ! SOUBROUTINE FOR AFM
19389        subroutine AFMvel(Eafmforce)
19390        use MD_data, only:totTafm
19391       real(kind=8),dimension(3) :: diffafm
19392       real(kind=8) :: afmdist,Eafmforce
19393        integer :: i
19394 !C Only for check grad COMMENT if not used for checkgrad
19395 !C      totT=3.0d0
19396 !C--------------------------------------------------------
19397 !C      print *,"wchodze"
19398       afmdist=0.0d0
19399       Eafmforce=0.0d0
19400       do i=1,3
19401       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19402       afmdist=afmdist+diffafm(i)**2
19403       enddo
19404       afmdist=dsqrt(afmdist)
19405 !      totTafm=3.0
19406       Eafmforce=0.5d0*forceAFMconst &
19407       *(distafminit+totTafm*velAFMconst-afmdist)**2
19408 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19409       do i=1,3
19410       gradafm(i,afmend-1)=-forceAFMconst* &
19411        (distafminit+totTafm*velAFMconst-afmdist) &
19412        *diffafm(i)/afmdist
19413       gradafm(i,afmbeg-1)=forceAFMconst* &
19414       (distafminit+totTafm*velAFMconst-afmdist) &
19415       *diffafm(i)/afmdist
19416       enddo
19417 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19418       return
19419       end subroutine AFMvel
19420 !---------------------------------------------------------
19421        subroutine AFMforce(Eafmforce)
19422
19423       real(kind=8),dimension(3) :: diffafm
19424 !      real(kind=8) ::afmdist
19425       real(kind=8) :: afmdist,Eafmforce
19426       integer :: i
19427       afmdist=0.0d0
19428       Eafmforce=0.0d0
19429       do i=1,3
19430       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19431       afmdist=afmdist+diffafm(i)**2
19432       enddo
19433       afmdist=dsqrt(afmdist)
19434 !      print *,afmdist,distafminit
19435       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19436       do i=1,3
19437       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19438       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19439       enddo
19440 !C      print *,'AFM',Eafmforce
19441       return
19442       end subroutine AFMforce
19443
19444 !-----------------------------------------------------------------------------
19445 #ifdef WHAM
19446       subroutine read_ssHist
19447 !      implicit none
19448 !      Includes
19449 !      include 'DIMENSIONS'
19450 !      include "DIMENSIONS.FREE"
19451 !      include 'COMMON.FREE'
19452 !     Local variables
19453       integer :: i,j
19454       character(len=80) :: controlcard
19455
19456       do i=1,dyn_nssHist
19457         call card_concat(controlcard,.true.)
19458         read(controlcard,*) &
19459              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19460       enddo
19461
19462       return
19463       end subroutine read_ssHist
19464 #endif
19465 !-----------------------------------------------------------------------------
19466       integer function indmat(i,j)
19467 !el
19468 ! get the position of the jth ijth fragment of the chain coordinate system
19469 ! in the fromto array.
19470         integer :: i,j
19471
19472         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19473       return
19474       end function indmat
19475 !-----------------------------------------------------------------------------
19476       real(kind=8) function sigm(x)
19477 !el
19478        real(kind=8) :: x
19479         sigm=0.25d0*x
19480       return
19481       end function sigm
19482 !-----------------------------------------------------------------------------
19483 !-----------------------------------------------------------------------------
19484       subroutine alloc_ener_arrays
19485 !EL Allocation of arrays used by module energy
19486       use MD_data, only: mset
19487 !el local variables
19488       integer :: i,j
19489
19490       if(nres.lt.100) then
19491         maxconts=nres
19492       elseif(nres.lt.200) then
19493         maxconts=0.8*nres      ! Max. number of contacts per residue
19494       else
19495         maxconts=0.6*nres ! (maxconts=maxres/4)
19496       endif
19497       maxcont=12*nres      ! Max. number of SC contacts
19498       maxvar=6*nres      ! Max. number of variables
19499 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19500       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19501 !----------------------
19502 ! arrays in subroutine init_int_table
19503 !el#ifdef MPI
19504 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19505 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19506 !el#endif
19507       allocate(nint_gr(nres))
19508       allocate(nscp_gr(nres))
19509       allocate(ielstart(nres))
19510       allocate(ielend(nres))
19511 !(maxres)
19512       allocate(istart(nres,maxint_gr))
19513       allocate(iend(nres,maxint_gr))
19514 !(maxres,maxint_gr)
19515       allocate(iscpstart(nres,maxint_gr))
19516       allocate(iscpend(nres,maxint_gr))
19517 !(maxres,maxint_gr)
19518       allocate(ielstart_vdw(nres))
19519       allocate(ielend_vdw(nres))
19520 !(maxres)
19521       allocate(nint_gr_nucl(nres))
19522       allocate(nscp_gr_nucl(nres))
19523       allocate(ielstart_nucl(nres))
19524       allocate(ielend_nucl(nres))
19525 !(maxres)
19526       allocate(istart_nucl(nres,maxint_gr))
19527       allocate(iend_nucl(nres,maxint_gr))
19528 !(maxres,maxint_gr)
19529       allocate(iscpstart_nucl(nres,maxint_gr))
19530       allocate(iscpend_nucl(nres,maxint_gr))
19531 !(maxres,maxint_gr)
19532       allocate(ielstart_vdw_nucl(nres))
19533       allocate(ielend_vdw_nucl(nres))
19534
19535       allocate(lentyp(0:nfgtasks-1))
19536 !(0:maxprocs-1)
19537 !----------------------
19538 ! commom.contacts
19539 !      common /contacts/
19540       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19541       allocate(icont(2,maxcont))
19542 !(2,maxcont)
19543 !      common /contacts1/
19544       allocate(num_cont(0:nres+4))
19545 !(maxres)
19546       allocate(jcont(maxconts,nres))
19547 !(maxconts,maxres)
19548       allocate(facont(maxconts,nres))
19549 !(maxconts,maxres)
19550       allocate(gacont(3,maxconts,nres))
19551 !(3,maxconts,maxres)
19552 !      common /contacts_hb/
19553       allocate(gacontp_hb1(3,maxconts,nres))
19554       allocate(gacontp_hb2(3,maxconts,nres))
19555       allocate(gacontp_hb3(3,maxconts,nres))
19556       allocate(gacontm_hb1(3,maxconts,nres))
19557       allocate(gacontm_hb2(3,maxconts,nres))
19558       allocate(gacontm_hb3(3,maxconts,nres))
19559       allocate(gacont_hbr(3,maxconts,nres))
19560       allocate(grij_hb_cont(3,maxconts,nres))
19561 !(3,maxconts,maxres)
19562       allocate(facont_hb(maxconts,nres))
19563
19564       allocate(ees0p(maxconts,nres))
19565       allocate(ees0m(maxconts,nres))
19566       allocate(d_cont(maxconts,nres))
19567       allocate(ees0plist(maxconts,nres))
19568
19569 !(maxconts,maxres)
19570       allocate(num_cont_hb(nres))
19571 !(maxres)
19572       allocate(jcont_hb(maxconts,nres))
19573 !(maxconts,maxres)
19574 !      common /rotat/
19575       allocate(Ug(2,2,nres))
19576       allocate(Ugder(2,2,nres))
19577       allocate(Ug2(2,2,nres))
19578       allocate(Ug2der(2,2,nres))
19579 !(2,2,maxres)
19580       allocate(obrot(2,nres))
19581       allocate(obrot2(2,nres))
19582       allocate(obrot_der(2,nres))
19583       allocate(obrot2_der(2,nres))
19584 !(2,maxres)
19585 !      common /precomp1/
19586       allocate(mu(2,nres))
19587       allocate(muder(2,nres))
19588       allocate(Ub2(2,nres))
19589       Ub2(1,:)=0.0d0
19590       Ub2(2,:)=0.0d0
19591       allocate(Ub2der(2,nres))
19592       allocate(Ctobr(2,nres))
19593       allocate(Ctobrder(2,nres))
19594       allocate(Dtobr2(2,nres))
19595       allocate(Dtobr2der(2,nres))
19596 !(2,maxres)
19597       allocate(EUg(2,2,nres))
19598       allocate(EUgder(2,2,nres))
19599       allocate(CUg(2,2,nres))
19600       allocate(CUgder(2,2,nres))
19601       allocate(DUg(2,2,nres))
19602       allocate(Dugder(2,2,nres))
19603       allocate(DtUg2(2,2,nres))
19604       allocate(DtUg2der(2,2,nres))
19605 !(2,2,maxres)
19606 !      common /precomp2/
19607       allocate(Ug2Db1t(2,nres))
19608       allocate(Ug2Db1tder(2,nres))
19609       allocate(CUgb2(2,nres))
19610       allocate(CUgb2der(2,nres))
19611 !(2,maxres)
19612       allocate(EUgC(2,2,nres))
19613       allocate(EUgCder(2,2,nres))
19614       allocate(EUgD(2,2,nres))
19615       allocate(EUgDder(2,2,nres))
19616       allocate(DtUg2EUg(2,2,nres))
19617       allocate(Ug2DtEUg(2,2,nres))
19618 !(2,2,maxres)
19619       allocate(Ug2DtEUgder(2,2,2,nres))
19620       allocate(DtUg2EUgder(2,2,2,nres))
19621 !(2,2,2,maxres)
19622 !      common /rotat_old/
19623       allocate(costab(nres))
19624       allocate(sintab(nres))
19625       allocate(costab2(nres))
19626       allocate(sintab2(nres))
19627 !(maxres)
19628 !      common /dipmat/
19629       allocate(a_chuj(2,2,maxconts,nres))
19630 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19631       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19632 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19633 !      common /contdistrib/
19634       allocate(ncont_sent(nres))
19635       allocate(ncont_recv(nres))
19636
19637       allocate(iat_sent(nres))
19638 !(maxres)
19639       allocate(iint_sent(4,nres,nres))
19640       allocate(iint_sent_local(4,nres,nres))
19641 !(4,maxres,maxres)
19642       allocate(iturn3_sent(4,0:nres+4))
19643       allocate(iturn4_sent(4,0:nres+4))
19644       allocate(iturn3_sent_local(4,nres))
19645       allocate(iturn4_sent_local(4,nres))
19646 !(4,maxres)
19647       allocate(itask_cont_from(0:nfgtasks-1))
19648       allocate(itask_cont_to(0:nfgtasks-1))
19649 !(0:max_fg_procs-1)
19650
19651
19652
19653 !----------------------
19654 ! commom.deriv;
19655 !      common /derivat/
19656       allocate(dcdv(6,maxdim))
19657       allocate(dxdv(6,maxdim))
19658 !(6,maxdim)
19659       allocate(dxds(6,nres))
19660 !(6,maxres)
19661       allocate(gradx(3,-1:nres,0:2))
19662       allocate(gradc(3,-1:nres,0:2))
19663 !(3,maxres,2)
19664       allocate(gvdwx(3,-1:nres))
19665       allocate(gvdwc(3,-1:nres))
19666       allocate(gelc(3,-1:nres))
19667       allocate(gelc_long(3,-1:nres))
19668       allocate(gvdwpp(3,-1:nres))
19669       allocate(gvdwc_scpp(3,-1:nres))
19670       allocate(gradx_scp(3,-1:nres))
19671       allocate(gvdwc_scp(3,-1:nres))
19672       allocate(ghpbx(3,-1:nres))
19673       allocate(ghpbc(3,-1:nres))
19674       allocate(gradcorr(3,-1:nres))
19675       allocate(gradcorr_long(3,-1:nres))
19676       allocate(gradcorr5_long(3,-1:nres))
19677       allocate(gradcorr6_long(3,-1:nres))
19678       allocate(gcorr6_turn_long(3,-1:nres))
19679       allocate(gradxorr(3,-1:nres))
19680       allocate(gradcorr5(3,-1:nres))
19681       allocate(gradcorr6(3,-1:nres))
19682       allocate(gliptran(3,-1:nres))
19683       allocate(gliptranc(3,-1:nres))
19684       allocate(gliptranx(3,-1:nres))
19685       allocate(gshieldx(3,-1:nres))
19686       allocate(gshieldc(3,-1:nres))
19687       allocate(gshieldc_loc(3,-1:nres))
19688       allocate(gshieldx_ec(3,-1:nres))
19689       allocate(gshieldc_ec(3,-1:nres))
19690       allocate(gshieldc_loc_ec(3,-1:nres))
19691       allocate(gshieldx_t3(3,-1:nres))
19692       allocate(gshieldc_t3(3,-1:nres))
19693       allocate(gshieldc_loc_t3(3,-1:nres))
19694       allocate(gshieldx_t4(3,-1:nres))
19695       allocate(gshieldc_t4(3,-1:nres))
19696       allocate(gshieldc_loc_t4(3,-1:nres))
19697       allocate(gshieldx_ll(3,-1:nres))
19698       allocate(gshieldc_ll(3,-1:nres))
19699       allocate(gshieldc_loc_ll(3,-1:nres))
19700       allocate(grad_shield(3,-1:nres))
19701       allocate(gg_tube_sc(3,-1:nres))
19702       allocate(gg_tube(3,-1:nres))
19703       allocate(gradafm(3,-1:nres))
19704       allocate(gradb_nucl(3,-1:nres))
19705       allocate(gradbx_nucl(3,-1:nres))
19706       allocate(gvdwpsb1(3,-1:nres))
19707       allocate(gelpp(3,-1:nres))
19708       allocate(gvdwpsb(3,-1:nres))
19709       allocate(gelsbc(3,-1:nres))
19710       allocate(gelsbx(3,-1:nres))
19711       allocate(gvdwsbx(3,-1:nres))
19712       allocate(gvdwsbc(3,-1:nres))
19713       allocate(gsbloc(3,-1:nres))
19714       allocate(gsblocx(3,-1:nres))
19715       allocate(gradcorr_nucl(3,-1:nres))
19716       allocate(gradxorr_nucl(3,-1:nres))
19717       allocate(gradcorr3_nucl(3,-1:nres))
19718       allocate(gradxorr3_nucl(3,-1:nres))
19719       allocate(gvdwpp_nucl(3,-1:nres))
19720
19721 !(3,maxres)
19722       allocate(grad_shield_side(3,50,nres))
19723       allocate(grad_shield_loc(3,50,nres))
19724 ! grad for shielding surroing
19725       allocate(gloc(0:maxvar,0:2))
19726       allocate(gloc_x(0:maxvar,2))
19727 !(maxvar,2)
19728       allocate(gel_loc(3,-1:nres))
19729       allocate(gel_loc_long(3,-1:nres))
19730       allocate(gcorr3_turn(3,-1:nres))
19731       allocate(gcorr4_turn(3,-1:nres))
19732       allocate(gcorr6_turn(3,-1:nres))
19733       allocate(gradb(3,-1:nres))
19734       allocate(gradbx(3,-1:nres))
19735 !(3,maxres)
19736       allocate(gel_loc_loc(maxvar))
19737       allocate(gel_loc_turn3(maxvar))
19738       allocate(gel_loc_turn4(maxvar))
19739       allocate(gel_loc_turn6(maxvar))
19740       allocate(gcorr_loc(maxvar))
19741       allocate(g_corr5_loc(maxvar))
19742       allocate(g_corr6_loc(maxvar))
19743 !(maxvar)
19744       allocate(gsccorc(3,-1:nres))
19745       allocate(gsccorx(3,-1:nres))
19746 !(3,maxres)
19747       allocate(gsccor_loc(-1:nres))
19748 !(maxres)
19749       allocate(dtheta(3,2,-1:nres))
19750 !(3,2,maxres)
19751       allocate(gscloc(3,-1:nres))
19752       allocate(gsclocx(3,-1:nres))
19753 !(3,maxres)
19754       allocate(dphi(3,3,-1:nres))
19755       allocate(dalpha(3,3,-1:nres))
19756       allocate(domega(3,3,-1:nres))
19757 !(3,3,maxres)
19758 !      common /deriv_scloc/
19759       allocate(dXX_C1tab(3,nres))
19760       allocate(dYY_C1tab(3,nres))
19761       allocate(dZZ_C1tab(3,nres))
19762       allocate(dXX_Ctab(3,nres))
19763       allocate(dYY_Ctab(3,nres))
19764       allocate(dZZ_Ctab(3,nres))
19765       allocate(dXX_XYZtab(3,nres))
19766       allocate(dYY_XYZtab(3,nres))
19767       allocate(dZZ_XYZtab(3,nres))
19768 !(3,maxres)
19769 !      common /mpgrad/
19770       allocate(jgrad_start(nres))
19771       allocate(jgrad_end(nres))
19772 !(maxres)
19773 !----------------------
19774
19775 !      common /indices/
19776       allocate(ibond_displ(0:nfgtasks-1))
19777       allocate(ibond_count(0:nfgtasks-1))
19778       allocate(ithet_displ(0:nfgtasks-1))
19779       allocate(ithet_count(0:nfgtasks-1))
19780       allocate(iphi_displ(0:nfgtasks-1))
19781       allocate(iphi_count(0:nfgtasks-1))
19782       allocate(iphi1_displ(0:nfgtasks-1))
19783       allocate(iphi1_count(0:nfgtasks-1))
19784       allocate(ivec_displ(0:nfgtasks-1))
19785       allocate(ivec_count(0:nfgtasks-1))
19786       allocate(iset_displ(0:nfgtasks-1))
19787       allocate(iset_count(0:nfgtasks-1))
19788       allocate(iint_count(0:nfgtasks-1))
19789       allocate(iint_displ(0:nfgtasks-1))
19790 !(0:max_fg_procs-1)
19791 !----------------------
19792 ! common.MD
19793 !      common /mdgrad/
19794       allocate(gcart(3,-1:nres))
19795       allocate(gxcart(3,-1:nres))
19796 !(3,0:MAXRES)
19797       allocate(gradcag(3,-1:nres))
19798       allocate(gradxag(3,-1:nres))
19799 !(3,MAXRES)
19800 !      common /back_constr/
19801 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19802       allocate(dutheta(nres))
19803       allocate(dugamma(nres))
19804 !(maxres)
19805       allocate(duscdiff(3,nres))
19806       allocate(duscdiffx(3,nres))
19807 !(3,maxres)
19808 !el i io:read_fragments
19809 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19810 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19811 !      common /qmeas/
19812 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19813 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19814       allocate(mset(0:nprocs))  !(maxprocs/20)
19815       mset(:)=0
19816 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19817 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19818       allocate(dUdconst(3,0:nres))
19819       allocate(dUdxconst(3,0:nres))
19820       allocate(dqwol(3,0:nres))
19821       allocate(dxqwol(3,0:nres))
19822 !(3,0:MAXRES)
19823 !----------------------
19824 ! common.sbridge
19825 !      common /sbridge/ in io_common: read_bridge
19826 !el    allocate((:),allocatable :: iss      !(maxss)
19827 !      common /links/  in io_common: read_bridge
19828 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19829 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19830 !      common /dyn_ssbond/
19831 ! and side-chain vectors in theta or phi.
19832       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19833 !(maxres,maxres)
19834 !      do i=1,nres
19835 !        do j=i+1,nres
19836       dyn_ssbond_ij(:,:)=1.0d300
19837 !        enddo
19838 !      enddo
19839
19840 !      if (nss.gt.0) then
19841         allocate(idssb(maxdim),jdssb(maxdim))
19842 !        allocate(newihpb(nss),newjhpb(nss))
19843 !(maxdim)
19844 !      endif
19845       allocate(ishield_list(nres))
19846       allocate(shield_list(50,nres))
19847       allocate(dyn_ss_mask(nres))
19848       allocate(fac_shield(nres))
19849       allocate(enetube(nres*2))
19850       allocate(enecavtube(nres*2))
19851
19852 !(maxres)
19853       dyn_ss_mask(:)=.false.
19854 !----------------------
19855 ! common.sccor
19856 ! Parameters of the SCCOR term
19857 !      common/sccor/
19858 !el in io_conf: parmread
19859 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
19860 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
19861 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
19862 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
19863 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
19864 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
19865 !      allocate(vlor1sccor(maxterm_sccor,20,20))
19866 !      allocate(vlor2sccor(maxterm_sccor,20,20))
19867 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
19868 !----------------
19869       allocate(gloc_sc(3,0:2*nres,0:10))
19870 !(3,0:maxres2,10)maxres2=2*maxres
19871       allocate(dcostau(3,3,3,2*nres))
19872       allocate(dsintau(3,3,3,2*nres))
19873       allocate(dtauangle(3,3,3,2*nres))
19874       allocate(dcosomicron(3,3,3,2*nres))
19875       allocate(domicron(3,3,3,2*nres))
19876 !(3,3,3,maxres2)maxres2=2*maxres
19877 !----------------------
19878 ! common.var
19879 !      common /restr/
19880       allocate(varall(maxvar))
19881 !(maxvar)(maxvar=6*maxres)
19882       allocate(mask_theta(nres))
19883       allocate(mask_phi(nres))
19884       allocate(mask_side(nres))
19885 !(maxres)
19886 !----------------------
19887 ! common.vectors
19888 !      common /vectors/
19889       allocate(uy(3,nres))
19890       allocate(uz(3,nres))
19891 !(3,maxres)
19892       allocate(uygrad(3,3,2,nres))
19893       allocate(uzgrad(3,3,2,nres))
19894 !(3,3,2,maxres)
19895
19896       return
19897       end subroutine alloc_ener_arrays
19898 !-----------------------------------------------------------------
19899       subroutine ebond_nucl(estr_nucl)
19900 !c
19901 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
19902 !c
19903
19904       real(kind=8),dimension(3) :: u,ud
19905       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
19906       real(kind=8) :: estr_nucl,diff
19907       integer :: iti,i,j,k,nbi
19908       estr_nucl=0.0d0
19909 !C      print *,"I enter ebond"
19910       if (energy_dec) &
19911       write (iout,*) "ibondp_start,ibondp_end",&
19912        ibondp_nucl_start,ibondp_nucl_end
19913       do i=ibondp_nucl_start,ibondp_nucl_end
19914         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
19915          itype(i,2).eq.ntyp1_molec(2)) cycle
19916 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
19917 !          do j=1,3
19918 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
19919 !     &      *dc(j,i-1)/vbld(i)
19920 !          enddo
19921 !          if (energy_dec) write(iout,*)
19922 !     &       "estr1",i,vbld(i),distchainmax,
19923 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
19924
19925           diff = vbld(i)-vbldp0_nucl
19926           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
19927           vbldp0_nucl,diff,AKP_nucl*diff*diff
19928           estr_nucl=estr_nucl+diff*diff
19929 !          print *,estr_nucl
19930           do j=1,3
19931             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
19932           enddo
19933 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
19934       enddo
19935       estr_nucl=0.5d0*AKP_nucl*estr_nucl
19936 !      print *,"partial sum", estr_nucl,AKP_nucl
19937
19938       if (energy_dec) &
19939       write (iout,*) "ibondp_start,ibondp_end",&
19940        ibond_nucl_start,ibond_nucl_end
19941
19942       do i=ibond_nucl_start,ibond_nucl_end
19943 !C        print *, "I am stuck",i
19944         iti=itype(i,2)
19945         if (iti.eq.ntyp1_molec(2)) cycle
19946           nbi=nbondterm_nucl(iti)
19947 !C        print *,iti,nbi
19948           if (nbi.eq.1) then
19949             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
19950
19951             if (energy_dec) &
19952            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
19953            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
19954             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
19955 !            print *,estr_nucl
19956             do j=1,3
19957               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
19958             enddo
19959           else
19960             do j=1,nbi
19961               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
19962               ud(j)=aksc_nucl(j,iti)*diff
19963               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
19964             enddo
19965             uprod=u(1)
19966             do j=2,nbi
19967               uprod=uprod*u(j)
19968             enddo
19969             usum=0.0d0
19970             usumsqder=0.0d0
19971             do j=1,nbi
19972               uprod1=1.0d0
19973               uprod2=1.0d0
19974               do k=1,nbi
19975                 if (k.ne.j) then
19976                   uprod1=uprod1*u(k)
19977                   uprod2=uprod2*u(k)*u(k)
19978                 endif
19979               enddo
19980               usum=usum+uprod1
19981               usumsqder=usumsqder+ud(j)*uprod2
19982             enddo
19983             estr_nucl=estr_nucl+uprod/usum
19984             do j=1,3
19985              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
19986             enddo
19987         endif
19988       enddo
19989 !C      print *,"I am about to leave ebond"
19990       return
19991       end subroutine ebond_nucl
19992
19993 !-----------------------------------------------------------------------------
19994       subroutine ebend_nucl(etheta_nucl)
19995       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
19996       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
19997       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
19998       logical :: lprn=.false., lprn1=.false.
19999 !el local variables
20000       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20001       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20002       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20003 ! local variables for constrains
20004       real(kind=8) :: difi,thetiii
20005        integer itheta
20006       etheta_nucl=0.0D0
20007 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20008       do i=ithet_nucl_start,ithet_nucl_end
20009         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20010         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20011         (itype(i,2).eq.ntyp1_molec(2))) cycle
20012         dethetai=0.0d0
20013         dephii=0.0d0
20014         dephii1=0.0d0
20015         theti2=0.5d0*theta(i)
20016         ityp2=ithetyp_nucl(itype(i-1,2))
20017         do k=1,nntheterm_nucl
20018           coskt(k)=dcos(k*theti2)
20019           sinkt(k)=dsin(k*theti2)
20020         enddo
20021         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20022 #ifdef OSF
20023           phii=phi(i)
20024           if (phii.ne.phii) phii=150.0
20025 #else
20026           phii=phi(i)
20027 #endif
20028           ityp1=ithetyp_nucl(itype(i-2,2))
20029           do k=1,nsingle_nucl
20030             cosph1(k)=dcos(k*phii)
20031             sinph1(k)=dsin(k*phii)
20032           enddo
20033         else
20034           phii=0.0d0
20035           ityp1=nthetyp_nucl+1
20036           do k=1,nsingle_nucl
20037             cosph1(k)=0.0d0
20038             sinph1(k)=0.0d0
20039           enddo
20040         endif
20041
20042         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20043 #ifdef OSF
20044           phii1=phi(i+1)
20045           if (phii1.ne.phii1) phii1=150.0
20046           phii1=pinorm(phii1)
20047 #else
20048           phii1=phi(i+1)
20049 #endif
20050           ityp3=ithetyp_nucl(itype(i,2))
20051           do k=1,nsingle_nucl
20052             cosph2(k)=dcos(k*phii1)
20053             sinph2(k)=dsin(k*phii1)
20054           enddo
20055         else
20056           phii1=0.0d0
20057           ityp3=nthetyp_nucl+1
20058           do k=1,nsingle_nucl
20059             cosph2(k)=0.0d0
20060             sinph2(k)=0.0d0
20061           enddo
20062         endif
20063         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20064         do k=1,ndouble_nucl
20065           do l=1,k-1
20066             ccl=cosph1(l)*cosph2(k-l)
20067             ssl=sinph1(l)*sinph2(k-l)
20068             scl=sinph1(l)*cosph2(k-l)
20069             csl=cosph1(l)*sinph2(k-l)
20070             cosph1ph2(l,k)=ccl-ssl
20071             cosph1ph2(k,l)=ccl+ssl
20072             sinph1ph2(l,k)=scl+csl
20073             sinph1ph2(k,l)=scl-csl
20074           enddo
20075         enddo
20076         if (lprn) then
20077         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20078          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20079         write (iout,*) "coskt and sinkt",nntheterm_nucl
20080         do k=1,nntheterm_nucl
20081           write (iout,*) k,coskt(k),sinkt(k)
20082         enddo
20083         endif
20084         do k=1,ntheterm_nucl
20085           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20086           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20087            *coskt(k)
20088           if (lprn)&
20089          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20090           " ethetai",ethetai
20091         enddo
20092         if (lprn) then
20093         write (iout,*) "cosph and sinph"
20094         do k=1,nsingle_nucl
20095           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20096         enddo
20097         write (iout,*) "cosph1ph2 and sinph2ph2"
20098         do k=2,ndouble_nucl
20099           do l=1,k-1
20100             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20101               sinph1ph2(l,k),sinph1ph2(k,l)
20102           enddo
20103         enddo
20104         write(iout,*) "ethetai",ethetai
20105         endif
20106         do m=1,ntheterm2_nucl
20107           do k=1,nsingle_nucl
20108             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20109               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20110               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20111               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20112             ethetai=ethetai+sinkt(m)*aux
20113             dethetai=dethetai+0.5d0*m*aux*coskt(m)
20114             dephii=dephii+k*sinkt(m)*(&
20115                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20116                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20117             dephii1=dephii1+k*sinkt(m)*(&
20118                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20119                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20120             if (lprn) &
20121            write (iout,*) "m",m," k",k," bbthet",&
20122               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20123               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20124               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20125               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20126           enddo
20127         enddo
20128         if (lprn) &
20129         write(iout,*) "ethetai",ethetai
20130         do m=1,ntheterm3_nucl
20131           do k=2,ndouble_nucl
20132             do l=1,k-1
20133               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20134                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20135                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20136                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20137               ethetai=ethetai+sinkt(m)*aux
20138               dethetai=dethetai+0.5d0*m*coskt(m)*aux
20139               dephii=dephii+l*sinkt(m)*(&
20140                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20141                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20142                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20143                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20144               dephii1=dephii1+(k-l)*sinkt(m)*( &
20145                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20146                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20147                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20148                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20149               if (lprn) then
20150               write (iout,*) "m",m," k",k," l",l," ffthet", &
20151                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20152                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20153                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20154                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20155               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20156                  cosph1ph2(k,l)*sinkt(m),&
20157                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20158               endif
20159             enddo
20160           enddo
20161         enddo
20162 10      continue
20163         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20164         i,theta(i)*rad2deg,phii*rad2deg, &
20165         phii1*rad2deg,ethetai
20166         etheta_nucl=etheta_nucl+ethetai
20167 !        print *,i,"partial sum",etheta_nucl
20168         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20169         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20170         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20171       enddo
20172       return
20173       end subroutine ebend_nucl
20174 !----------------------------------------------------
20175       subroutine etor_nucl(etors_nucl)
20176 !      implicit real*8 (a-h,o-z)
20177 !      include 'DIMENSIONS'
20178 !      include 'COMMON.VAR'
20179 !      include 'COMMON.GEO'
20180 !      include 'COMMON.LOCAL'
20181 !      include 'COMMON.TORSION'
20182 !      include 'COMMON.INTERACT'
20183 !      include 'COMMON.DERIV'
20184 !      include 'COMMON.CHAIN'
20185 !      include 'COMMON.NAMES'
20186 !      include 'COMMON.IOUNITS'
20187 !      include 'COMMON.FFIELD'
20188 !      include 'COMMON.TORCNSTR'
20189 !      include 'COMMON.CONTROL'
20190       real(kind=8) :: etors_nucl,edihcnstr
20191       logical :: lprn
20192 !el local variables
20193       integer :: i,j,iblock,itori,itori1
20194       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20195                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20196 ! Set lprn=.true. for debugging
20197       lprn=.false.
20198 !     lprn=.true.
20199       etors_nucl=0.0D0
20200 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20201       do i=iphi_nucl_start,iphi_nucl_end
20202         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20203              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20204              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20205         etors_ii=0.0D0
20206         itori=itortyp_nucl(itype(i-2,2))
20207         itori1=itortyp_nucl(itype(i-1,2))
20208         phii=phi(i)
20209 !         print *,i,itori,itori1
20210         gloci=0.0D0
20211 !C Regular cosine and sine terms
20212         do j=1,nterm_nucl(itori,itori1)
20213           v1ij=v1_nucl(j,itori,itori1)
20214           v2ij=v2_nucl(j,itori,itori1)
20215           cosphi=dcos(j*phii)
20216           sinphi=dsin(j*phii)
20217           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20218           if (energy_dec) etors_ii=etors_ii+&
20219                      v1ij*cosphi+v2ij*sinphi
20220           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20221         enddo
20222 !C Lorentz terms
20223 !C                         v1
20224 !C  E = SUM ----------------------------------- - v1
20225 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20226 !C
20227         cosphi=dcos(0.5d0*phii)
20228         sinphi=dsin(0.5d0*phii)
20229         do j=1,nlor_nucl(itori,itori1)
20230           vl1ij=vlor1_nucl(j,itori,itori1)
20231           vl2ij=vlor2_nucl(j,itori,itori1)
20232           vl3ij=vlor3_nucl(j,itori,itori1)
20233           pom=vl2ij*cosphi+vl3ij*sinphi
20234           pom1=1.0d0/(pom*pom+1.0d0)
20235           etors_nucl=etors_nucl+vl1ij*pom1
20236           if (energy_dec) etors_ii=etors_ii+ &
20237                      vl1ij*pom1
20238           pom=-pom*pom1*pom1
20239           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20240         enddo
20241 !C Subtract the constant term
20242         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20243           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20244               'etor',i,etors_ii-v0_nucl(itori,itori1)
20245         if (lprn) &
20246        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20247        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20248        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20249         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20250 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20251       enddo
20252       return
20253       end subroutine etor_nucl
20254 !------------------------------------------------------------
20255       subroutine epp_nucl_sub(evdw1,ees)
20256 !C
20257 !C This subroutine calculates the average interaction energy and its gradient
20258 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20259 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20260 !C The potential depends both on the distance of peptide-group centers and on
20261 !C the orientation of the CA-CA virtual bonds.
20262 !C
20263       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20264       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
20265       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20266                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20267                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20268       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20269                     dist_temp, dist_init,sss_grad,fac,evdw1ij
20270       integer xshift,yshift,zshift
20271       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20272       real(kind=8) :: ees,eesij
20273 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20274       real(kind=8) scal_el /0.5d0/
20275       t_eelecij=0.0d0
20276       ees=0.0D0
20277       evdw1=0.0D0
20278       ind=0
20279 !c
20280 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20281 !c
20282 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20283       do i=iatel_s_nucl,iatel_e_nucl
20284         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20285         dxi=dc(1,i)
20286         dyi=dc(2,i)
20287         dzi=dc(3,i)
20288         dx_normi=dc_norm(1,i)
20289         dy_normi=dc_norm(2,i)
20290         dz_normi=dc_norm(3,i)
20291         xmedi=c(1,i)+0.5d0*dxi
20292         ymedi=c(2,i)+0.5d0*dyi
20293         zmedi=c(3,i)+0.5d0*dzi
20294           xmedi=dmod(xmedi,boxxsize)
20295           if (xmedi.lt.0) xmedi=xmedi+boxxsize
20296           ymedi=dmod(ymedi,boxysize)
20297           if (ymedi.lt.0) ymedi=ymedi+boxysize
20298           zmedi=dmod(zmedi,boxzsize)
20299           if (zmedi.lt.0) zmedi=zmedi+boxzsize
20300
20301         do j=ielstart_nucl(i),ielend_nucl(i)
20302           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20303           ind=ind+1
20304           dxj=dc(1,j)
20305           dyj=dc(2,j)
20306           dzj=dc(3,j)
20307 !          xj=c(1,j)+0.5D0*dxj-xmedi
20308 !          yj=c(2,j)+0.5D0*dyj-ymedi
20309 !          zj=c(3,j)+0.5D0*dzj-zmedi
20310           xj=c(1,j)+0.5D0*dxj
20311           yj=c(2,j)+0.5D0*dyj
20312           zj=c(3,j)+0.5D0*dzj
20313           xj=mod(xj,boxxsize)
20314           if (xj.lt.0) xj=xj+boxxsize
20315           yj=mod(yj,boxysize)
20316           if (yj.lt.0) yj=yj+boxysize
20317           zj=mod(zj,boxzsize)
20318           if (zj.lt.0) zj=zj+boxzsize
20319       isubchap=0
20320       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20321       xj_safe=xj
20322       yj_safe=yj
20323       zj_safe=zj
20324       do xshift=-1,1
20325       do yshift=-1,1
20326       do zshift=-1,1
20327           xj=xj_safe+xshift*boxxsize
20328           yj=yj_safe+yshift*boxysize
20329           zj=zj_safe+zshift*boxzsize
20330           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20331           if(dist_temp.lt.dist_init) then
20332             dist_init=dist_temp
20333             xj_temp=xj
20334             yj_temp=yj
20335             zj_temp=zj
20336             isubchap=1
20337           endif
20338        enddo
20339        enddo
20340        enddo
20341        if (isubchap.eq.1) then
20342 !C          print *,i,j
20343           xj=xj_temp-xmedi
20344           yj=yj_temp-ymedi
20345           zj=zj_temp-zmedi
20346        else
20347           xj=xj_safe-xmedi
20348           yj=yj_safe-ymedi
20349           zj=zj_safe-zmedi
20350        endif
20351
20352           rij=xj*xj+yj*yj+zj*zj
20353 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20354           fac=(r0pp**2/rij)**3
20355           ev1=epspp*fac*fac
20356           ev2=epspp*fac
20357           evdw1ij=ev1-2*ev2
20358           fac=(-ev1-evdw1ij)/rij
20359 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20360           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20361           evdw1=evdw1+evdw1ij
20362 !C
20363 !C Calculate contributions to the Cartesian gradient.
20364 !C
20365           ggg(1)=fac*xj
20366           ggg(2)=fac*yj
20367           ggg(3)=fac*zj
20368           do k=1,3
20369             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20370             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20371           enddo
20372 !c phoshate-phosphate electrostatic interactions
20373           rij=dsqrt(rij)
20374           fac=1.0d0/rij
20375           eesij=dexp(-BEES*rij)*fac
20376 !          write (2,*)"fac",fac," eesijpp",eesij
20377           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
20378           ees=ees+eesij
20379 !c          fac=-eesij*fac
20380           fac=-(fac+BEES)*eesij*fac
20381           ggg(1)=fac*xj
20382           ggg(2)=fac*yj
20383           ggg(3)=fac*zj
20384 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
20385 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
20386 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
20387           do k=1,3
20388             gelpp(k,i)=gelpp(k,i)-ggg(k)
20389             gelpp(k,j)=gelpp(k,j)+ggg(k)
20390           enddo
20391         enddo ! j
20392       enddo   ! i
20393 !c      ees=332.0d0*ees
20394       ees=AEES*ees
20395       do i=nnt,nct
20396 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20397         do k=1,3
20398           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
20399 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
20400           gelpp(k,i)=AEES*gelpp(k,i)
20401         enddo
20402 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20403       enddo
20404 !c      write (2,*) "total EES",ees
20405       return
20406       end subroutine epp_nucl_sub
20407 !---------------------------------------------------------------------
20408       subroutine epsb(evdwpsb,eelpsb)
20409 !      use comm_locel
20410 !C
20411 !C This subroutine calculates the excluded-volume interaction energy between
20412 !C peptide-group centers and side chains and its gradient in virtual-bond and
20413 !C side-chain vectors.
20414 !C
20415       real(kind=8),dimension(3):: ggg
20416       integer :: i,iint,j,k,iteli,itypj,subchap
20417       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
20418                    e1,e2,evdwij,rij,evdwpsb,eelpsb
20419       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20420                     dist_temp, dist_init
20421       integer xshift,yshift,zshift
20422
20423 !cd    print '(a)','Enter ESCP'
20424 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
20425       eelpsb=0.0d0
20426       evdwpsb=0.0d0
20427 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
20428       do i=iatscp_s_nucl,iatscp_e_nucl
20429         if (itype(i,2).eq.ntyp1_molec(2) &
20430          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20431         xi=0.5D0*(c(1,i)+c(1,i+1))
20432         yi=0.5D0*(c(2,i)+c(2,i+1))
20433         zi=0.5D0*(c(3,i)+c(3,i+1))
20434           xi=mod(xi,boxxsize)
20435           if (xi.lt.0) xi=xi+boxxsize
20436           yi=mod(yi,boxysize)
20437           if (yi.lt.0) yi=yi+boxysize
20438           zi=mod(zi,boxzsize)
20439           if (zi.lt.0) zi=zi+boxzsize
20440
20441         do iint=1,nscp_gr_nucl(i)
20442
20443         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
20444           itypj=itype(j,2)
20445           if (itypj.eq.ntyp1_molec(2)) cycle
20446 !C Uncomment following three lines for SC-p interactions
20447 !c         xj=c(1,nres+j)-xi
20448 !c         yj=c(2,nres+j)-yi
20449 !c         zj=c(3,nres+j)-zi
20450 !C Uncomment following three lines for Ca-p interactions
20451 !          xj=c(1,j)-xi
20452 !          yj=c(2,j)-yi
20453 !          zj=c(3,j)-zi
20454           xj=c(1,j)
20455           yj=c(2,j)
20456           zj=c(3,j)
20457           xj=mod(xj,boxxsize)
20458           if (xj.lt.0) xj=xj+boxxsize
20459           yj=mod(yj,boxysize)
20460           if (yj.lt.0) yj=yj+boxysize
20461           zj=mod(zj,boxzsize)
20462           if (zj.lt.0) zj=zj+boxzsize
20463       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20464       xj_safe=xj
20465       yj_safe=yj
20466       zj_safe=zj
20467       subchap=0
20468       do xshift=-1,1
20469       do yshift=-1,1
20470       do zshift=-1,1
20471           xj=xj_safe+xshift*boxxsize
20472           yj=yj_safe+yshift*boxysize
20473           zj=zj_safe+zshift*boxzsize
20474           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20475           if(dist_temp.lt.dist_init) then
20476             dist_init=dist_temp
20477             xj_temp=xj
20478             yj_temp=yj
20479             zj_temp=zj
20480             subchap=1
20481           endif
20482        enddo
20483        enddo
20484        enddo
20485        if (subchap.eq.1) then
20486           xj=xj_temp-xi
20487           yj=yj_temp-yi
20488           zj=zj_temp-zi
20489        else
20490           xj=xj_safe-xi
20491           yj=yj_safe-yi
20492           zj=zj_safe-zi
20493        endif
20494
20495           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20496           fac=rrij**expon2
20497           e1=fac*fac*aad_nucl(itypj)
20498           e2=fac*bad_nucl(itypj)
20499           if (iabs(j-i) .le. 2) then
20500             e1=scal14*e1
20501             e2=scal14*e2
20502           endif
20503           evdwij=e1+e2
20504           evdwpsb=evdwpsb+evdwij
20505           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
20506              'evdw2',i,j,evdwij,"tu4"
20507 !C
20508 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
20509 !C
20510           fac=-(evdwij+e1)*rrij
20511           ggg(1)=xj*fac
20512           ggg(2)=yj*fac
20513           ggg(3)=zj*fac
20514           do k=1,3
20515             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
20516             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
20517           enddo
20518         enddo
20519
20520         enddo ! iint
20521       enddo ! i
20522       do i=1,nct
20523         do j=1,3
20524           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
20525           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
20526         enddo
20527       enddo
20528       return
20529       end subroutine epsb
20530
20531 !------------------------------------------------------
20532       subroutine esb_gb(evdwsb,eelsb)
20533       use comm_locel
20534       use calc_data_nucl
20535       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
20536       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
20537       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
20538       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20539                     dist_temp, dist_init,aa,bb,faclip,sig0ij
20540       integer :: ii
20541       logical lprn
20542       evdw=0.0D0
20543       eelsb=0.0d0
20544       ecorr=0.0d0
20545       evdwsb=0.0D0
20546       lprn=.false.
20547       ind=0
20548 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
20549       do i=iatsc_s_nucl,iatsc_e_nucl
20550         num_conti=0
20551         num_conti2=0
20552         itypi=itype(i,2)
20553 !        PRINT *,"I=",i,itypi
20554         if (itypi.eq.ntyp1_molec(2)) cycle
20555         itypi1=itype(i+1,2)
20556         xi=c(1,nres+i)
20557         yi=c(2,nres+i)
20558         zi=c(3,nres+i)
20559           xi=dmod(xi,boxxsize)
20560           if (xi.lt.0) xi=xi+boxxsize
20561           yi=dmod(yi,boxysize)
20562           if (yi.lt.0) yi=yi+boxysize
20563           zi=dmod(zi,boxzsize)
20564           if (zi.lt.0) zi=zi+boxzsize
20565
20566         dxi=dc_norm(1,nres+i)
20567         dyi=dc_norm(2,nres+i)
20568         dzi=dc_norm(3,nres+i)
20569         dsci_inv=vbld_inv(i+nres)
20570 !C
20571 !C Calculate SC interaction energy.
20572 !C
20573         do iint=1,nint_gr_nucl(i)
20574 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
20575           do j=istart_nucl(i,iint),iend_nucl(i,iint)
20576             ind=ind+1
20577 !            print *,"JESTEM"
20578             itypj=itype(j,2)
20579             if (itypj.eq.ntyp1_molec(2)) cycle
20580             dscj_inv=vbld_inv(j+nres)
20581             sig0ij=sigma_nucl(itypi,itypj)
20582             chi1=chi_nucl(itypi,itypj)
20583             chi2=chi_nucl(itypj,itypi)
20584             chi12=chi1*chi2
20585             chip1=chip_nucl(itypi,itypj)
20586             chip2=chip_nucl(itypj,itypi)
20587             chip12=chip1*chip2
20588 !            xj=c(1,nres+j)-xi
20589 !            yj=c(2,nres+j)-yi
20590 !            zj=c(3,nres+j)-zi
20591            xj=c(1,nres+j)
20592            yj=c(2,nres+j)
20593            zj=c(3,nres+j)
20594           xj=dmod(xj,boxxsize)
20595           if (xj.lt.0) xj=xj+boxxsize
20596           yj=dmod(yj,boxysize)
20597           if (yj.lt.0) yj=yj+boxysize
20598           zj=dmod(zj,boxzsize)
20599           if (zj.lt.0) zj=zj+boxzsize
20600       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20601       xj_safe=xj
20602       yj_safe=yj
20603       zj_safe=zj
20604       subchap=0
20605       do xshift=-1,1
20606       do yshift=-1,1
20607       do zshift=-1,1
20608           xj=xj_safe+xshift*boxxsize
20609           yj=yj_safe+yshift*boxysize
20610           zj=zj_safe+zshift*boxzsize
20611           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20612           if(dist_temp.lt.dist_init) then
20613             dist_init=dist_temp
20614             xj_temp=xj
20615             yj_temp=yj
20616             zj_temp=zj
20617             subchap=1
20618           endif
20619        enddo
20620        enddo
20621        enddo
20622        if (subchap.eq.1) then
20623           xj=xj_temp-xi
20624           yj=yj_temp-yi
20625           zj=zj_temp-zi
20626        else
20627           xj=xj_safe-xi
20628           yj=yj_safe-yi
20629           zj=zj_safe-zi
20630        endif
20631
20632             dxj=dc_norm(1,nres+j)
20633             dyj=dc_norm(2,nres+j)
20634             dzj=dc_norm(3,nres+j)
20635             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20636             rij=dsqrt(rrij)
20637 !C Calculate angle-dependent terms of energy and contributions to their
20638 !C derivatives.
20639             erij(1)=xj*rij
20640             erij(2)=yj*rij
20641             erij(3)=zj*rij
20642             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
20643             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
20644             om12=dxi*dxj+dyi*dyj+dzi*dzj
20645             call sc_angular_nucl
20646             sigsq=1.0D0/sigsq
20647             sig=sig0ij*dsqrt(sigsq)
20648             rij_shift=1.0D0/rij-sig+sig0ij
20649 !            print *,rij_shift,"rij_shift"
20650 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
20651 !c     &       " rij_shift",rij_shift
20652             if (rij_shift.le.0.0D0) then
20653               evdw=1.0D20
20654               return
20655             endif
20656             sigder=-sig*sigsq
20657 !c---------------------------------------------------------------
20658             rij_shift=1.0D0/rij_shift
20659             fac=rij_shift**expon
20660             e1=fac*fac*aa_nucl(itypi,itypj)
20661             e2=fac*bb_nucl(itypi,itypj)
20662             evdwij=eps1*eps2rt*(e1+e2)
20663 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
20664 !c     &       " e1",e1," e2",e2," evdwij",evdwij
20665             eps2der=evdwij
20666             evdwij=evdwij*eps2rt
20667             evdwsb=evdwsb+evdwij
20668             if (lprn) then
20669             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
20670             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
20671             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
20672              restyp(itypi,2),i,restyp(itypj,2),j, &
20673              epsi,sigm,chi1,chi2,chip1,chip2, &
20674              eps1,eps2rt**2,sig,sig0ij, &
20675              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
20676             evdwij
20677             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
20678             endif
20679
20680             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
20681                              'evdw',i,j,evdwij,"tu3"
20682
20683
20684 !C Calculate gradient components.
20685             e1=e1*eps1*eps2rt**2
20686             fac=-expon*(e1+evdwij)*rij_shift
20687             sigder=fac*sigder
20688             fac=rij*fac
20689 !c            fac=0.0d0
20690 !C Calculate the radial part of the gradient
20691             gg(1)=xj*fac
20692             gg(2)=yj*fac
20693             gg(3)=zj*fac
20694 !C Calculate angular part of the gradient.
20695             call sc_grad_nucl
20696             call eelsbij(eelij,num_conti2)
20697             if (energy_dec .and. &
20698            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
20699           write (istat,'(e14.5)') evdwij
20700             eelsb=eelsb+eelij
20701           enddo      ! j
20702         enddo        ! iint
20703         num_cont_hb(i)=num_conti2
20704       enddo          ! i
20705 !c      write (iout,*) "Number of loop steps in EGB:",ind
20706 !cccc      energy_dec=.false.
20707       return
20708       end subroutine esb_gb
20709 !-------------------------------------------------------------------------------
20710       subroutine eelsbij(eesij,num_conti2)
20711       use comm_locel
20712       use calc_data_nucl
20713       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
20714       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
20715       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20716                     dist_temp, dist_init,rlocshield,fracinbuf
20717       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
20718
20719 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20720       real(kind=8) scal_el /0.5d0/
20721       integer :: iteli,itelj,kkk,kkll,m,isubchap
20722       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
20723       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
20724       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
20725                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
20726                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
20727                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
20728                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
20729                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
20730                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
20731                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
20732       ind=ind+1
20733       itypi=itype(i,2)
20734       itypj=itype(j,2)
20735 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
20736       ael6i=ael6_nucl(itypi,itypj)
20737       ael3i=ael3_nucl(itypi,itypj)
20738       ael63i=ael63_nucl(itypi,itypj)
20739       ael32i=ael32_nucl(itypi,itypj)
20740 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
20741 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
20742       dxj=dc(1,j+nres)
20743       dyj=dc(2,j+nres)
20744       dzj=dc(3,j+nres)
20745       dx_normi=dc_norm(1,i+nres)
20746       dy_normi=dc_norm(2,i+nres)
20747       dz_normi=dc_norm(3,i+nres)
20748       dx_normj=dc_norm(1,j+nres)
20749       dy_normj=dc_norm(2,j+nres)
20750       dz_normj=dc_norm(3,j+nres)
20751 !c      xj=c(1,j)+0.5D0*dxj-xmedi
20752 !c      yj=c(2,j)+0.5D0*dyj-ymedi
20753 !c      zj=c(3,j)+0.5D0*dzj-zmedi
20754       if (ipot_nucl.ne.2) then
20755         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
20756         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
20757         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
20758       else
20759         cosa=om12
20760         cosb=om1
20761         cosg=om2
20762       endif
20763       r3ij=rij*rrij
20764       r6ij=r3ij*r3ij
20765       fac=cosa-3.0D0*cosb*cosg
20766       facfac=fac*fac
20767       fac1=3.0d0*(cosb*cosb+cosg*cosg)
20768       fac3=ael6i*r6ij
20769       fac4=ael3i*r3ij
20770       fac5=ael63i*r6ij
20771       fac6=ael32i*r6ij
20772 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
20773 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
20774       el1=fac3*(4.0D0+facfac-fac1)
20775       el2=fac4*fac
20776       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
20777       el4=fac6*facfac
20778       eesij=el1+el2+el3+el4
20779 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
20780       ees0ij=4.0D0+facfac-fac1
20781
20782       if (energy_dec) then
20783           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
20784           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
20785            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
20786            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
20787            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
20788           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
20789       endif
20790
20791 !C
20792 !C Calculate contributions to the Cartesian gradient.
20793 !C
20794       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
20795       fac1=fac
20796 !c      erij(1)=xj*rmij
20797 !c      erij(2)=yj*rmij
20798 !c      erij(3)=zj*rmij
20799 !*
20800 !* Radial derivatives. First process both termini of the fragment (i,j)
20801 !*
20802       ggg(1)=facel*xj
20803       ggg(2)=facel*yj
20804       ggg(3)=facel*zj
20805       do k=1,3
20806         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20807         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20808         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
20809         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
20810       enddo
20811 !*
20812 !* Angular part
20813 !*
20814       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
20815       fac4=-3.0D0*fac4
20816       fac3=-6.0D0*fac3
20817       fac5= 6.0d0*fac5
20818       fac6=-6.0d0*fac6
20819       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
20820        fac6*fac1*cosg
20821       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
20822        fac6*fac1*cosb
20823       do k=1,3
20824         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
20825         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
20826       enddo
20827       do k=1,3
20828         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
20829       enddo
20830       do k=1,3
20831         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
20832              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
20833              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20834         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
20835              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
20836              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20837         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20838         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20839       enddo
20840 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
20841        IF ( j.gt.i+1 .and.&
20842           num_conti.le.maxconts) THEN
20843 !C
20844 !C Calculate the contact function. The ith column of the array JCONT will
20845 !C contain the numbers of atoms that make contacts with the atom I (of numbers
20846 !C greater than I). The arrays FACONT and GACONT will contain the values of
20847 !C the contact function and its derivative.
20848         r0ij=2.20D0*sigma(itypi,itypj)
20849 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
20850         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
20851 !c        write (2,*) "fcont",fcont
20852         if (fcont.gt.0.0D0) then
20853           num_conti=num_conti+1
20854           num_conti2=num_conti2+1
20855
20856           if (num_conti.gt.maxconts) then
20857             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
20858                           ' will skip next contacts for this conf.'
20859           else
20860             jcont_hb(num_conti,i)=j
20861 !c            write (iout,*) "num_conti",num_conti,
20862 !c     &        " jcont_hb",jcont_hb(num_conti,i)
20863 !C Calculate contact energies
20864             cosa4=4.0D0*cosa
20865             wij=cosa-3.0D0*cosb*cosg
20866             cosbg1=cosb+cosg
20867             cosbg2=cosb-cosg
20868             fac3=dsqrt(-ael6i)*r3ij
20869 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
20870             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
20871             if (ees0tmp.gt.0) then
20872               ees0pij=dsqrt(ees0tmp)
20873             else
20874               ees0pij=0
20875             endif
20876             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
20877             if (ees0tmp.gt.0) then
20878               ees0mij=dsqrt(ees0tmp)
20879             else
20880               ees0mij=0
20881             endif
20882             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
20883             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
20884 !c            write (iout,*) "i",i," j",j,
20885 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
20886             ees0pij1=fac3/ees0pij
20887             ees0mij1=fac3/ees0mij
20888             fac3p=-3.0D0*fac3*rrij
20889             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
20890             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
20891             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
20892             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
20893             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
20894             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
20895             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
20896             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
20897             ecosap=ecosa1+ecosa2
20898             ecosbp=ecosb1+ecosb2
20899             ecosgp=ecosg1+ecosg2
20900             ecosam=ecosa1-ecosa2
20901             ecosbm=ecosb1-ecosb2
20902             ecosgm=ecosg1-ecosg2
20903 !C End diagnostics
20904             facont_hb(num_conti,i)=fcont
20905             fprimcont=fprimcont/rij
20906             do k=1,3
20907               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
20908               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
20909             enddo
20910             gggp(1)=gggp(1)+ees0pijp*xj
20911             gggp(2)=gggp(2)+ees0pijp*yj
20912             gggp(3)=gggp(3)+ees0pijp*zj
20913             gggm(1)=gggm(1)+ees0mijp*xj
20914             gggm(2)=gggm(2)+ees0mijp*yj
20915             gggm(3)=gggm(3)+ees0mijp*zj
20916 !C Derivatives due to the contact function
20917             gacont_hbr(1,num_conti,i)=fprimcont*xj
20918             gacont_hbr(2,num_conti,i)=fprimcont*yj
20919             gacont_hbr(3,num_conti,i)=fprimcont*zj
20920             do k=1,3
20921 !c
20922 !c Gradient of the correlation terms
20923 !c
20924               gacontp_hb1(k,num_conti,i)= &
20925              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
20926             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20927               gacontp_hb2(k,num_conti,i)= &
20928              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
20929             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20930               gacontp_hb3(k,num_conti,i)=gggp(k)
20931               gacontm_hb1(k,num_conti,i)= &
20932              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
20933             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20934               gacontm_hb2(k,num_conti,i)= &
20935              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
20936             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20937               gacontm_hb3(k,num_conti,i)=gggm(k)
20938             enddo
20939           endif
20940         endif
20941       ENDIF
20942       return
20943       end subroutine eelsbij
20944 !------------------------------------------------------------------
20945       subroutine sc_grad_nucl
20946       use comm_locel
20947       use calc_data_nucl
20948       real(kind=8),dimension(3) :: dcosom1,dcosom2
20949       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
20950       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
20951       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
20952       do k=1,3
20953         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
20954         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
20955       enddo
20956       do k=1,3
20957         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
20958       enddo
20959       do k=1,3
20960         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
20961                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
20962                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
20963         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
20964                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
20965                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
20966       enddo
20967 !C
20968 !C Calculate the components of the gradient in DC and X
20969 !C
20970       do l=1,3
20971         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
20972         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
20973       enddo
20974       return
20975       end subroutine sc_grad_nucl
20976 !-----------------------------------------------------------------------
20977       subroutine esb(esbloc)
20978 !C Calculate the local energy of a side chain and its derivatives in the
20979 !C corresponding virtual-bond valence angles THETA and the spherical angles
20980 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
20981 !C added by Urszula Kozlowska. 07/11/2007
20982 !C
20983       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
20984       real(kind=8),dimension(9):: x
20985      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
20986       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
20987       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
20988       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
20989        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
20990        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
20991        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
20992        integer::it,nlobit,i,j,k
20993 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
20994       delta=0.02d0*pi
20995       esbloc=0.0D0
20996       do i=loc_start_nucl,loc_end_nucl
20997         if (itype(i,2).eq.ntyp1_molec(2)) cycle
20998         costtab(i+1) =dcos(theta(i+1))
20999         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21000         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21001         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21002         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21003         cosfac=dsqrt(cosfac2)
21004         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21005         sinfac=dsqrt(sinfac2)
21006         it=itype(i,2)
21007         if (it.eq.10) goto 1
21008
21009 !c
21010 !C  Compute the axes of tghe local cartesian coordinates system; store in
21011 !c   x_prime, y_prime and z_prime
21012 !c
21013         do j=1,3
21014           x_prime(j) = 0.00
21015           y_prime(j) = 0.00
21016           z_prime(j) = 0.00
21017         enddo
21018 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21019 !C     &   dc_norm(3,i+nres)
21020         do j = 1,3
21021           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21022           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21023         enddo
21024         do j = 1,3
21025           z_prime(j) = -uz(j,i-1)
21026 !           z_prime(j)=0.0
21027         enddo
21028
21029         xx=0.0d0
21030         yy=0.0d0
21031         zz=0.0d0
21032         do j = 1,3
21033           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21034           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21035           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21036         enddo
21037
21038         xxtab(i)=xx
21039         yytab(i)=yy
21040         zztab(i)=zz
21041          it=itype(i,2)
21042         do j = 1,9
21043           x(j) = sc_parmin_nucl(j,it)
21044         enddo
21045 #ifdef CHECK_COORD
21046 !Cc diagnostics - remove later
21047         xx1 = dcos(alph(2))
21048         yy1 = dsin(alph(2))*dcos(omeg(2))
21049         zz1 = -dsin(alph(2))*dsin(omeg(2))
21050         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21051          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21052          xx1,yy1,zz1
21053 !C,"  --- ", xx_w,yy_w,zz_w
21054 !c end diagnostics
21055 #endif
21056         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21057         esbloc = esbloc + sumene
21058         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21059 !        print *,"enecomp",sumene,sumene2
21060 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21061 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21062 #ifdef DEBUG
21063         write (2,*) "x",(x(k),k=1,9)
21064 !C
21065 !C This section to check the numerical derivatives of the energy of ith side
21066 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21067 !C #define DEBUG in the code to turn it on.
21068 !C
21069         write (2,*) "sumene               =",sumene
21070         aincr=1.0d-7
21071         xxsave=xx
21072         xx=xx+aincr
21073         write (2,*) xx,yy,zz
21074         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21075         de_dxx_num=(sumenep-sumene)/aincr
21076         xx=xxsave
21077         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21078         yysave=yy
21079         yy=yy+aincr
21080         write (2,*) xx,yy,zz
21081         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21082         de_dyy_num=(sumenep-sumene)/aincr
21083         yy=yysave
21084         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21085         zzsave=zz
21086         zz=zz+aincr
21087         write (2,*) xx,yy,zz
21088         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21089         de_dzz_num=(sumenep-sumene)/aincr
21090         zz=zzsave
21091         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21092         costsave=cost2tab(i+1)
21093         sintsave=sint2tab(i+1)
21094         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21095         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21096         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21097         de_dt_num=(sumenep-sumene)/aincr
21098         write (2,*) " t+ sumene from enesc=",sumenep,sumene
21099         cost2tab(i+1)=costsave
21100         sint2tab(i+1)=sintsave
21101 !C End of diagnostics section.
21102 #endif
21103 !C
21104 !C Compute the gradient of esc
21105 !C
21106         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21107         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21108         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21109         de_dtt=0.0d0
21110 #ifdef DEBUG
21111         write (2,*) "x",(x(k),k=1,9)
21112         write (2,*) "xx",xx," yy",yy," zz",zz
21113         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21114           " de_zz   ",de_zz," de_tt   ",de_tt
21115         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21116           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21117 #endif
21118 !C
21119        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21120        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21121        cosfac2xx=cosfac2*xx
21122        sinfac2yy=sinfac2*yy
21123        do k = 1,3
21124          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21125            vbld_inv(i+1)
21126          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21127            vbld_inv(i)
21128          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21129          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21130 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21131 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21132 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21133 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21134          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21135          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21136          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21137          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21138          dZZ_Ci1(k)=0.0d0
21139          dZZ_Ci(k)=0.0d0
21140          do j=1,3
21141            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21142            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21143          enddo
21144
21145          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21146          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21147          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21148 !c
21149          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21150          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21151        enddo
21152
21153        do k=1,3
21154          dXX_Ctab(k,i)=dXX_Ci(k)
21155          dXX_C1tab(k,i)=dXX_Ci1(k)
21156          dYY_Ctab(k,i)=dYY_Ci(k)
21157          dYY_C1tab(k,i)=dYY_Ci1(k)
21158          dZZ_Ctab(k,i)=dZZ_Ci(k)
21159          dZZ_C1tab(k,i)=dZZ_Ci1(k)
21160          dXX_XYZtab(k,i)=dXX_XYZ(k)
21161          dYY_XYZtab(k,i)=dYY_XYZ(k)
21162          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21163        enddo
21164        do k = 1,3
21165 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21166 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21167 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21168 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21169 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21170 !c     &    dt_dci(k)
21171 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21172 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21173          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21174          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21175          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21176          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21177          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21178          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21179 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21180        enddo
21181 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21182 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21183
21184 !C to check gradient call subroutine check_grad
21185
21186     1 continue
21187       enddo
21188       return
21189       end subroutine esb
21190 !=-------------------------------------------------------
21191       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21192 !      implicit none
21193       real(kind=8),dimension(9):: x(9)
21194        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21195       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21196       integer i
21197 !c      write (2,*) "enesc"
21198 !c      write (2,*) "x",(x(i),i=1,9)
21199 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21200       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21201         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21202         + x(9)*yy*zz
21203       enesc_nucl=sumene
21204       return
21205       end function enesc_nucl
21206 !-----------------------------------------------------------------------------
21207       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21208 #ifdef MPI
21209       include 'mpif.h'
21210       integer,parameter :: max_cont=2000
21211       integer,parameter:: max_dim=2*(8*3+6)
21212       integer, parameter :: msglen1=max_cont*max_dim
21213       integer,parameter :: msglen2=2*msglen1
21214       integer source,CorrelType,CorrelID,Error
21215       real(kind=8) :: buffer(max_cont,max_dim)
21216       integer status(MPI_STATUS_SIZE)
21217       integer :: ierror,nbytes
21218 #endif
21219       real(kind=8),dimension(3):: gx(3),gx1(3)
21220       real(kind=8) :: time00
21221       logical lprn,ldone
21222       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21223       real(kind=8) ecorr,ecorr3
21224       integer :: n_corr,n_corr1,mm,msglen
21225 !C Set lprn=.true. for debugging
21226       lprn=.false.
21227       n_corr=0
21228       n_corr1=0
21229 #ifdef MPI
21230       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21231
21232       if (nfgtasks.le.1) goto 30
21233       if (lprn) then
21234         write (iout,'(a)') 'Contact function values:'
21235         do i=nnt,nct-1
21236           write (iout,'(2i3,50(1x,i2,f5.2))')  &
21237          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21238          j=1,num_cont_hb(i))
21239         enddo
21240       endif
21241 !C Caution! Following code assumes that electrostatic interactions concerning
21242 !C a given atom are split among at most two processors!
21243       CorrelType=477
21244       CorrelID=fg_rank+1
21245       ldone=.false.
21246       do i=1,max_cont
21247         do j=1,max_dim
21248           buffer(i,j)=0.0D0
21249         enddo
21250       enddo
21251       mm=mod(fg_rank,2)
21252 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21253       if (mm) 20,20,10
21254    10 continue
21255 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21256       if (fg_rank.gt.0) then
21257 !C Send correlation contributions to the preceding processor
21258         msglen=msglen1
21259         nn=num_cont_hb(iatel_s_nucl)
21260         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21261 !c        write (*,*) 'The BUFFER array:'
21262 !c        do i=1,nn
21263 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21264 !c        enddo
21265         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21266           msglen=msglen2
21267           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21268 !C Clear the contacts of the atom passed to the neighboring processor
21269         nn=num_cont_hb(iatel_s_nucl+1)
21270 !c        do i=1,nn
21271 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21272 !c        enddo
21273             num_cont_hb(iatel_s_nucl)=0
21274         endif
21275 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21276 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21277 !cd   & ' msglen=',msglen
21278 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21279 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21280 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21281         time00=MPI_Wtime()
21282         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21283          CorrelType,FG_COMM,IERROR)
21284         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21285 !cd      write (iout,*) 'Processor ',fg_rank,
21286 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21287 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21288 !c        write (*,*) 'Processor ',fg_rank,
21289 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21290 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21291 !c        msglen=msglen1
21292       endif ! (fg_rank.gt.0)
21293       if (ldone) goto 30
21294       ldone=.true.
21295    20 continue
21296 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21297       if (fg_rank.lt.nfgtasks-1) then
21298 !C Receive correlation contributions from the next processor
21299         msglen=msglen1
21300         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21301 !cd      write (iout,*) 'Processor',fg_rank,
21302 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21303 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21304 !c        write (*,*) 'Processor',fg_rank,
21305 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21306 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21307         time00=MPI_Wtime()
21308         nbytes=-1
21309         do while (nbytes.le.0)
21310           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21311           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21312         enddo
21313 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21314         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21315          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21316         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21317 !c        write (*,*) 'Processor',fg_rank,
21318 !c     &' has received correlation contribution from processor',fg_rank+1,
21319 !c     & ' msglen=',msglen,' nbytes=',nbytes
21320 !c        write (*,*) 'The received BUFFER array:'
21321 !c        do i=1,max_cont
21322 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21323 !c        enddo
21324         if (msglen.eq.msglen1) then
21325           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21326         else if (msglen.eq.msglen2)  then
21327           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21328           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21329         else
21330           write (iout,*) &
21331       'ERROR!!!! message length changed while processing correlations.'
21332           write (*,*) &
21333       'ERROR!!!! message length changed while processing correlations.'
21334           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21335         endif ! msglen.eq.msglen1
21336       endif ! fg_rank.lt.nfgtasks-1
21337       if (ldone) goto 30
21338       ldone=.true.
21339       goto 10
21340    30 continue
21341 #endif
21342       if (lprn) then
21343         write (iout,'(a)') 'Contact function values:'
21344         do i=nnt_molec(2),nct_molec(2)-1
21345           write (iout,'(2i3,50(1x,i2,f5.2))') &
21346          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21347          j=1,num_cont_hb(i))
21348         enddo
21349       endif
21350       ecorr=0.0D0
21351       ecorr3=0.0d0
21352 !C Remove the loop below after debugging !!!
21353 !      do i=nnt_molec(2),nct_molec(2)
21354 !        do j=1,3
21355 !          gradcorr_nucl(j,i)=0.0D0
21356 !          gradxorr_nucl(j,i)=0.0D0
21357 !          gradcorr3_nucl(j,i)=0.0D0
21358 !          gradxorr3_nucl(j,i)=0.0D0
21359 !        enddo
21360 !      enddo
21361 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21362 !C Calculate the local-electrostatic correlation terms
21363       do i=iatsc_s_nucl,iatsc_e_nucl
21364         i1=i+1
21365         num_conti=num_cont_hb(i)
21366         num_conti1=num_cont_hb(i+1)
21367 !        print *,i,num_conti,num_conti1
21368         do jj=1,num_conti
21369           j=jcont_hb(jj,i)
21370           do kk=1,num_conti1
21371             j1=jcont_hb(kk,i1)
21372 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21373 !c     &         ' jj=',jj,' kk=',kk
21374             if (j1.eq.j+1 .or. j1.eq.j-1) then
21375 !C
21376 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21377 !C The system gains extra energy.
21378 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21379 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21380 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21381 !C
21382               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21383               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21384                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21385               n_corr=n_corr+1
21386             else if (j1.eq.j) then
21387 !C
21388 !C Contacts I-J and I-(J+1) occur simultaneously.
21389 !C The system loses extra energy.
21390 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21391 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21392 !C Need to implement full formulas 32 from Liwo et al., 1998.
21393 !C
21394 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21395 !c     &         ' jj=',jj,' kk=',kk
21396               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21397             endif
21398           enddo ! kk
21399           do kk=1,num_conti
21400             j1=jcont_hb(kk,i)
21401 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21402 !c     &         ' jj=',jj,' kk=',kk
21403             if (j1.eq.j+1) then
21404 !C Contacts I-J and (I+1)-J occur simultaneously.
21405 !C The system loses extra energy.
21406               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21407             endif ! j1==j+1
21408           enddo ! kk
21409         enddo ! jj
21410       enddo ! i
21411       return
21412       end subroutine multibody_hb_nucl
21413 !-----------------------------------------------------------
21414       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21415 !      implicit real*8 (a-h,o-z)
21416 !      include 'DIMENSIONS'
21417 !      include 'COMMON.IOUNITS'
21418 !      include 'COMMON.DERIV'
21419 !      include 'COMMON.INTERACT'
21420 !      include 'COMMON.CONTACTS'
21421       real(kind=8),dimension(3) :: gx,gx1
21422       logical :: lprn
21423 !el local variables
21424       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21425       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21426                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21427                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21428                    rlocshield
21429
21430       lprn=.false.
21431       eij=facont_hb(jj,i)
21432       ekl=facont_hb(kk,k)
21433       ees0pij=ees0p(jj,i)
21434       ees0pkl=ees0p(kk,k)
21435       ees0mij=ees0m(jj,i)
21436       ees0mkl=ees0m(kk,k)
21437       ekont=eij*ekl
21438       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21439 !      print *,"ehbcorr_nucl",ekont,ees
21440 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21441 !C Following 4 lines for diagnostics.
21442 !cd    ees0pkl=0.0D0
21443 !cd    ees0pij=1.0D0
21444 !cd    ees0mkl=0.0D0
21445 !cd    ees0mij=1.0D0
21446 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21447 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21448 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21449 !C Calculate the multi-body contribution to energy.
21450 !      ecorr_nucl=ecorr_nucl+ekont*ees
21451 !C Calculate multi-body contributions to the gradient.
21452       coeffpees0pij=coeffp*ees0pij
21453       coeffmees0mij=coeffm*ees0mij
21454       coeffpees0pkl=coeffp*ees0pkl
21455       coeffmees0mkl=coeffm*ees0mkl
21456       do ll=1,3
21457         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
21458        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21459        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21460         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
21461         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
21462         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21463         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
21464         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
21465         coeffmees0mij*gacontm_hb1(ll,kk,k))
21466         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
21467         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21468         coeffmees0mij*gacontm_hb2(ll,kk,k))
21469         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21470           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21471           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21472         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
21473         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
21474         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21475           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21476           coeffmees0mij*gacontm_hb3(ll,kk,k))
21477         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
21478         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
21479         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
21480         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
21481         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
21482         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
21483       enddo
21484       ehbcorr_nucl=ekont*ees
21485       return
21486       end function ehbcorr_nucl
21487 !-------------------------------------------------------------------------
21488
21489      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21490 !      implicit real*8 (a-h,o-z)
21491 !      include 'DIMENSIONS'
21492 !      include 'COMMON.IOUNITS'
21493 !      include 'COMMON.DERIV'
21494 !      include 'COMMON.INTERACT'
21495 !      include 'COMMON.CONTACTS'
21496       real(kind=8),dimension(3) :: gx,gx1
21497       logical :: lprn
21498 !el local variables
21499       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21500       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21501                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21502                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21503                    rlocshield
21504
21505       lprn=.false.
21506       eij=facont_hb(jj,i)
21507       ekl=facont_hb(kk,k)
21508       ees0pij=ees0p(jj,i)
21509       ees0pkl=ees0p(kk,k)
21510       ees0mij=ees0m(jj,i)
21511       ees0mkl=ees0m(kk,k)
21512       ekont=eij*ekl
21513       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21514 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21515 !C Following 4 lines for diagnostics.
21516 !cd    ees0pkl=0.0D0
21517 !cd    ees0pij=1.0D0
21518 !cd    ees0mkl=0.0D0
21519 !cd    ees0mij=1.0D0
21520 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21521 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21522 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21523 !C Calculate the multi-body contribution to energy.
21524 !      ecorr=ecorr+ekont*ees
21525 !C Calculate multi-body contributions to the gradient.
21526       coeffpees0pij=coeffp*ees0pij
21527       coeffmees0mij=coeffm*ees0mij
21528       coeffpees0pkl=coeffp*ees0pkl
21529       coeffmees0mkl=coeffm*ees0mkl
21530       do ll=1,3
21531         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
21532        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21533        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21534         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
21535         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
21536         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21537         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
21538         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
21539         coeffmees0mij*gacontm_hb1(ll,kk,k))
21540         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
21541         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21542         coeffmees0mij*gacontm_hb2(ll,kk,k))
21543         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21544           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21545           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21546         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
21547         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
21548         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21549           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21550           coeffmees0mij*gacontm_hb3(ll,kk,k))
21551         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
21552         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
21553         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
21554         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
21555         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
21556         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
21557       enddo
21558       ehbcorr3_nucl=ekont*ees
21559       return
21560       end function ehbcorr3_nucl
21561 #ifdef MPI
21562       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
21563       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21564       real(kind=8):: buffer(dimen1,dimen2)
21565       num_kont=num_cont_hb(atom)
21566       do i=1,num_kont
21567         do k=1,8
21568           do j=1,3
21569             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
21570           enddo ! j
21571         enddo ! k
21572         buffer(i,indx+25)=facont_hb(i,atom)
21573         buffer(i,indx+26)=ees0p(i,atom)
21574         buffer(i,indx+27)=ees0m(i,atom)
21575         buffer(i,indx+28)=d_cont(i,atom)
21576         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
21577       enddo ! i
21578       buffer(1,indx+30)=dfloat(num_kont)
21579       return
21580       end subroutine pack_buffer
21581 !c------------------------------------------------------------------------------
21582       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
21583       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21584       real(kind=8):: buffer(dimen1,dimen2)
21585 !      double precision zapas
21586 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
21587 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
21588 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
21589 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
21590       num_kont=buffer(1,indx+30)
21591       num_kont_old=num_cont_hb(atom)
21592       num_cont_hb(atom)=num_kont+num_kont_old
21593       do i=1,num_kont
21594         ii=i+num_kont_old
21595         do k=1,8
21596           do j=1,3
21597             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
21598           enddo ! j
21599         enddo ! k
21600         facont_hb(ii,atom)=buffer(i,indx+25)
21601         ees0p(ii,atom)=buffer(i,indx+26)
21602         ees0m(ii,atom)=buffer(i,indx+27)
21603         d_cont(i,atom)=buffer(i,indx+28)
21604         jcont_hb(ii,atom)=buffer(i,indx+29)
21605       enddo ! i
21606       return
21607       end subroutine unpack_buffer
21608 !c------------------------------------------------------------------------------
21609 #endif
21610       subroutine ecatcat(ecationcation)
21611         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
21612         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21613         r7,r4,ecationcation,k0,rcal
21614         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21615         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
21616         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21617         gg,r
21618
21619         ecationcation=0.0d0
21620         if (nres_molec(5).eq.0) return
21621         rcat0=3.472
21622         epscalc=0.05
21623         r06 = rcat0**6
21624         r012 = r06**2
21625         k0 = 332*(2*2)/80
21626         itmp=0
21627         do i=1,4
21628         itmp=itmp+nres_molec(i)
21629         enddo
21630         do i=itmp+1,itmp+nres_molec(i)-1
21631         xi=c(1,i)
21632         yi=c(2,i)
21633         zi=c(3,i)
21634           xi=mod(xi,boxxsize)
21635           if (xi.lt.0) xi=xi+boxxsize
21636           yi=mod(yi,boxysize)
21637           if (yi.lt.0) yi=yi+boxysize
21638           zi=mod(zi,boxzsize)
21639           if (zi.lt.0) zi=zi+boxzsize
21640
21641           do j=i+1,itmp+nres_molec(i)
21642            xj=c(1,j)
21643            yj=c(2,j)
21644            zj=c(3,j)
21645           xj=dmod(xj,boxxsize)
21646           if (xj.lt.0) xj=xj+boxxsize
21647           yj=dmod(yj,boxysize)
21648           if (yj.lt.0) yj=yj+boxysize
21649           zj=dmod(zj,boxzsize)
21650           if (zj.lt.0) zj=zj+boxzsize
21651       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21652       xj_safe=xj
21653       yj_safe=yj
21654       zj_safe=zj
21655       subchap=0
21656       do xshift=-1,1
21657       do yshift=-1,1
21658       do zshift=-1,1
21659           xj=xj_safe+xshift*boxxsize
21660           yj=yj_safe+yshift*boxysize
21661           zj=zj_safe+zshift*boxzsize
21662           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21663           if(dist_temp.lt.dist_init) then
21664             dist_init=dist_temp
21665             xj_temp=xj
21666             yj_temp=yj
21667             zj_temp=zj
21668             subchap=1
21669           endif
21670        enddo
21671        enddo
21672        enddo
21673        if (subchap.eq.1) then
21674           xj=xj_temp-xi
21675           yj=yj_temp-yi
21676           zj=zj_temp-zi
21677        else
21678           xj=xj_safe-xi
21679           yj=yj_safe-yi
21680           zj=zj_safe-zi
21681        endif
21682        rcal =xj**2+yj**2+zj**2
21683         ract=sqrt(rcal)
21684 !        rcat0=3.472
21685 !        epscalc=0.05
21686 !        r06 = rcat0**6
21687 !        r012 = r06**2
21688 !        k0 = 332*(2*2)/80
21689         Evan1cat=epscalc*(r012/rcal**6)
21690         Evan2cat=epscalc*2*(r06/rcal**3)
21691         Eeleccat=k0/ract
21692         r7 = rcal**7
21693         r4 = rcal**4
21694         r(1)=xj
21695         r(2)=yj
21696         r(3)=zj
21697         do k=1,3
21698           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
21699           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
21700           dEeleccat(k)=-k0*r(k)/ract**3
21701         enddo
21702         do k=1,3
21703           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
21704           gradcatcat(k,i)=gradcatcat(k,i)+gg(k)
21705           gradcatcat(k,j)=gradcatcat(k,j)-gg(k)
21706         enddo
21707
21708         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
21709        enddo
21710        enddo
21711        return
21712        end subroutine ecatcat
21713 !---------------------------------------------------------------------------
21714        subroutine ecat_prot(ecation_prot)
21715        integer i,j,k,subchap,itmp
21716         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21717         r7,r4,ecationcation
21718         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21719         dist_init,dist_temp,ecation_prot
21720         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21721         gg,r
21722 ! first lets calculate interaction with peptide groups
21723         if (nres_molec(5).eq.0) return
21724         itmp=0
21725         do i=1,4
21726         itmp=itmp+nres_molec(i)
21727         enddo
21728         do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
21729          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
21730         xi=0.5d0*(c(1,i)+c(1,i+1))
21731         yi=0.5d0*(c(2,i)+c(2,i+1))
21732         zi=0.5d0*(c(3,i)+c(3,i+1))
21733           xi=mod(xi,boxxsize)
21734           if (xi.lt.0) xi=xi+boxxsize
21735           yi=mod(yi,boxysize)
21736           if (yi.lt.0) yi=yi+boxysize
21737           zi=mod(zi,boxzsize)
21738           if (zi.lt.0) zi=zi+boxzsize
21739
21740          do j=itmp+1,itmp+nres_molec(5)
21741            xj=c(1,j)
21742            yj=c(2,j)
21743            zj=c(3,j)
21744           xj=dmod(xj,boxxsize)
21745           if (xj.lt.0) xj=xj+boxxsize
21746           yj=dmod(yj,boxysize)
21747           if (yj.lt.0) yj=yj+boxysize
21748           zj=dmod(zj,boxzsize)
21749           if (zj.lt.0) zj=zj+boxzsize
21750       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21751       xj_safe=xj
21752       yj_safe=yj
21753       zj_safe=zj
21754       subchap=0
21755       do xshift=-1,1
21756       do yshift=-1,1
21757       do zshift=-1,1
21758           xj=xj_safe+xshift*boxxsize
21759           yj=yj_safe+yshift*boxysize
21760           zj=zj_safe+zshift*boxzsize
21761           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21762           if(dist_temp.lt.dist_init) then
21763             dist_init=dist_temp
21764             xj_temp=xj
21765             yj_temp=yj
21766             zj_temp=zj
21767             subchap=1
21768           endif
21769        enddo
21770        enddo
21771        enddo
21772        if (subchap.eq.1) then
21773           xj=xj_temp-xi
21774           yj=yj_temp-yi
21775           zj=zj_temp-zi
21776        else
21777           xj=xj_safe-xi
21778           yj=yj_safe-yi
21779           zj=zj_safe-zi
21780        endif
21781        enddo
21782        enddo
21783
21784
21785        return
21786        end subroutine ecat_prot
21787
21788 !----------------------------------------------------------------------------
21789 !-----------------------------------------------------------------------------
21790 !-----------------------------------------------------------------------------
21791       end module energy