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 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 131       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 132         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 133       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 134         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 135         g_corr6_loc     !(maxvar)
 136       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 137       real(kind=8),dimension(:),allocatable :: gsccor_loc       !(maxres)
 138 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 139       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 140 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 141       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 142          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 143 !      integer :: nfl,icg
 144 !      common /deriv_loc/
 145       real(kind=8), dimension(:),allocatable :: fac_shield
 146       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 147 !      common /deriv_scloc/
 148       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 149        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 150        dZZ_XYZtab       !(3,maxres)
 151 !-----------------------------------------------------------------------------
 152 ! common.maxgrad
 153 !      common /maxgrad/
 154       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 155        gradb_max,ghpbc_max,&
 156        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 157        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 158        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 159        gsccorx_max,gsclocx_max
 160 !-----------------------------------------------------------------------------
 161 ! common.MD
 162 !      common /back_constr/
 163       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 164       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 165 !      common /qmeas/
 166       real(kind=8) :: Ucdfrag,Ucdpair
 167       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 168        dqwol,dxqwol     !(3,0:MAXRES)
 169 !-----------------------------------------------------------------------------
 170 ! common.sbridge
 171 !      common /dyn_ssbond/
 172       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 173 !-----------------------------------------------------------------------------
 174 ! common.sccor
 175 ! Parameters of the SCCOR term
 176 !      common/sccor/
 177       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 178        dcosomicron,domicron     !(3,3,3,maxres2)
 179 !-----------------------------------------------------------------------------
 180 ! common.vectors
 181 !      common /vectors/
 182       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 183       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 184 !-----------------------------------------------------------------------------
 185 ! common /przechowalnia/
 186       real(kind=8),dimension(:,:,:),allocatable :: zapas !(max_dim,maxconts,max_fg_procs)
 187       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 188 !-----------------------------------------------------------------------------
 189 !-----------------------------------------------------------------------------
 190 !
 191 !
 192 !-----------------------------------------------------------------------------
 193       contains
 194 !-----------------------------------------------------------------------------
 195 ! energy_p_new_barrier.F
 196 !-----------------------------------------------------------------------------
 197       subroutine etotal(energia)
 198 !      implicit real*8 (a-h,o-z)
 199 !      include 'DIMENSIONS'
 200       use MD_data
 201 #ifndef ISNAN
 202       external proc_proc
 203 #ifdef WINPGI
 204 !MS$ATTRIBUTES C ::  proc_proc
 205 #endif
 206 #endif
 207 #ifdef MPI
 208       include "mpif.h"
 209 #endif
 210 !      include 'COMMON.SETUP'
 211 !      include 'COMMON.IOUNITS'
 212       real(kind=8),dimension(0:n_ene) :: energia
 213 !      include 'COMMON.LOCAL'
 214 !      include 'COMMON.FFIELD'
 215 !      include 'COMMON.DERIV'
 216 !      include 'COMMON.INTERACT'
 217 !      include 'COMMON.SBRIDGE'
 218 !      include 'COMMON.CHAIN'
 219 !      include 'COMMON.VAR'
 220 !      include 'COMMON.MD'
 221 !      include 'COMMON.CONTROL'
 222 !      include 'COMMON.TIME1'
 223       real(kind=8) :: time00
 224 !el local variables
 225       integer :: n_corr,n_corr1,ierror
 226       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 227       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 228       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 229                       Eafmforce,ethetacnstr
 230       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 231 ! now energies for nulceic alone parameters
 232       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 233                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 234                       ecorr3_nucl
 235 #ifdef MPI
 236       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 237 ! shielding effect varibles for MPI
 238 !      real(kind=8)   fac_shieldbuf(maxres),
 239 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 240 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 241 !     & grad_shieldbuf(3,-1:maxres)
 242 !       integer ishield_listbuf(maxres),
 243 !     &shield_listbuf(maxcontsshi,maxres)
 244
 245 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 246 !     & " nfgtasks",nfgtasks
 247       if (nfgtasks.gt.1) then
 248         time00=MPI_Wtime()
 249 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 250         if (fg_rank.eq.0) then
 251           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 252 !          print *,"Processor",myrank," BROADCAST iorder"
 253 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 254 ! FG slaves as WEIGHTS array.
 255           weights_(1)=wsc
 256           weights_(2)=wscp
 257           weights_(3)=welec
 258           weights_(4)=wcorr
 259           weights_(5)=wcorr5
 260           weights_(6)=wcorr6
 261           weights_(7)=wel_loc
 262           weights_(8)=wturn3
 263           weights_(9)=wturn4
 264           weights_(10)=wturn6
 265           weights_(11)=wang
 266           weights_(12)=wscloc
 267           weights_(13)=wtor
 268           weights_(14)=wtor_d
 269           weights_(15)=wstrain
 270           weights_(16)=wvdwpp
 271           weights_(17)=wbond
 272           weights_(18)=scal14
 273           weights_(21)=wsccor
 274 ! FG Master broadcasts the WEIGHTS_ array
 275           call MPI_Bcast(weights_(1),n_ene,&
 276              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 277         else
 278 ! FG slaves receive the WEIGHTS array
 279           call MPI_Bcast(weights(1),n_ene,&
 280               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 281           wsc=weights(1)
 282           wscp=weights(2)
 283           welec=weights(3)
 284           wcorr=weights(4)
 285           wcorr5=weights(5)
 286           wcorr6=weights(6)
 287           wel_loc=weights(7)
 288           wturn3=weights(8)
 289           wturn4=weights(9)
 290           wturn6=weights(10)
 291           wang=weights(11)
 292           wscloc=weights(12)
 293           wtor=weights(13)
 294           wtor_d=weights(14)
 295           wstrain=weights(15)
 296           wvdwpp=weights(16)
 297           wbond=weights(17)
 298           scal14=weights(18)
 299           wsccor=weights(21)
 300         endif
 301         time_Bcast=time_Bcast+MPI_Wtime()-time00
 302         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 303 !        call chainbuild_cart
 304       endif
 305 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 306 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 307 #else
 308 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 309 !        call int_from_cart1(.false.)
 310 !      endif
 311 #endif
 312 #ifdef TIMING
 313       time00=MPI_Wtime()
 314 #endif
 315 !
 316 ! Compute the side-chain and electrostatic interaction energy
 317 !        print *, "Before EVDW"
 318 !      goto (101,102,103,104,105,106) ipot
 319       select case(ipot)
 320 ! Lennard-Jones potential.
 321 !  101 call elj(evdw)
 322        case (1)
 323          call elj(evdw)
 324 !d    print '(a)','Exit ELJcall el'
 325 !      goto 107
 326 ! Lennard-Jones-Kihara potential (shifted).
 327 !  102 call eljk(evdw)
 328        case (2)
 329          call eljk(evdw)
 330 !      goto 107
 331 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 332 !  103 call ebp(evdw)
 333        case (3)
 334          call ebp(evdw)
 335 !      goto 107
 336 ! Gay-Berne potential (shifted LJ, angular dependence).
 337 !  104 call egb(evdw)
 338        case (4)
 339          call egb(evdw)
 340 !      goto 107
 341 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 342 !  105 call egbv(evdw)
 343        case (5)
 344          call egbv(evdw)
 345 !      goto 107
 346 ! Soft-sphere potential
 347 !  106 call e_softsphere(evdw)
 348        case (6)
 349          call e_softsphere(evdw)
 350 !
 351 ! Calculate electrostatic (H-bonding) energy of the main chain.
 352 !
 353 !  107 continue
 354        case default
 355          write(iout,*)"Wrong ipot"
 356 !         return
 357 !   50 continue
 358       end select
 359 !      continue
 360 !        print *,"after EGB"
 361 ! shielding effect
 362        if (shield_mode.eq.2) then
 363                  call set_shield_fac2
 364        endif
 365        print *,"AFTER EGB",ipot,evdw
 366 !mc
 367 !mc Sep-06: egb takes care of dynamic ss bonds too
 368 !mc
 369 !      if (dyn_ss) call dyn_set_nss
 370 !      print *,"Processor",myrank," computed USCSC"
 371 #ifdef TIMING
 372       time01=MPI_Wtime()
 373 #endif
 374       call vec_and_deriv
 375 #ifdef TIMING
 376       time_vec=time_vec+MPI_Wtime()-time01
 377 #endif
 378 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 379       if (ipot.lt.6) then
 380 #ifdef SPLITELE
 381 !         print *,"after ipot if", ipot
 382          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 383              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 384              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 385              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 386 #else
 387          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 388              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 389              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 390              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 391 #endif
 392 !            print *,"just befor eelec call"
 393             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 394 !         write (iout,*) "ELEC calc"
 395          else
 396             ees=0.0d0
 397             evdw1=0.0d0
 398             eel_loc=0.0d0
 399             eello_turn3=0.0d0
 400             eello_turn4=0.0d0
 401          endif
 402       else
 403 !        write (iout,*) "Soft-spheer ELEC potential"
 404         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 405          eello_turn4)
 406       endif
 407 !      print *,"Processor",myrank," computed UELEC"
 408 !
 409 ! Calculate excluded-volume interaction energy between peptide groups
 410 ! and side chains.
 411 !
 412 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 413
 414       if (ipot.lt.6) then
 415        if(wscp.gt.0d0) then
 416         call escp(evdw2,evdw2_14)
 417        else
 418         evdw2=0
 419         evdw2_14=0
 420        endif
 421       else
 422 !        write (iout,*) "Soft-sphere SCP potential"
 423         call escp_soft_sphere(evdw2,evdw2_14)
 424       endif
 425 !       write(iout,*) "in etotal before ebond",ipot
 426
 427 !
 428 ! Calculate the bond-stretching energy
 429 !
 430       call ebond(estr)
 431        print *,"EBOND",estr
 432 !       write(iout,*) "in etotal afer ebond",ipot
 433
 434 !
 435 ! Calculate the disulfide-bridge and other energy and the contributions
 436 ! from other distance constraints.
 437 !      print *,'Calling EHPB'
 438       call edis(ehpb)
 439 !elwrite(iout,*) "in etotal afer edis",ipot
 440 !      print *,'EHPB exitted succesfully.'
 441 !
 442 ! Calculate the virtual-bond-angle energy.
 443 !
 444       if (wang.gt.0d0) then
 445         call ebend(ebe,ethetacnstr)
 446       else
 447         ebe=0
 448       endif
 449 !      print *,"Processor",myrank," computed UB"
 450 !
 451 ! Calculate the SC local energy.
 452 !
 453       call esc(escloc)
 454 !elwrite(iout,*) "in etotal afer esc",ipot
 455 !      print *,"Processor",myrank," computed USC"
 456 !
 457 ! Calculate the virtual-bond torsional energy.
 458 !
 459 !d    print *,'nterm=',nterm
 460       if (wtor.gt.0) then
 461        call etor(etors,edihcnstr)
 462       else
 463        etors=0
 464        edihcnstr=0
 465       endif
 466 !      print *,"Processor",myrank," computed Utor"
 467 !
 468 ! 6/23/01 Calculate double-torsional energy
 469 !
 470 !elwrite(iout,*) "in etotal",ipot
 471       if (wtor_d.gt.0) then
 472        call etor_d(etors_d)
 473       else
 474        etors_d=0
 475       endif
 476 !      print *,"Processor",myrank," computed Utord"
 477 !
 478 ! 21/5/07 Calculate local sicdechain correlation energy
 479 !
 480       if (wsccor.gt.0.0d0) then
 481         call eback_sc_corr(esccor)
 482       else
 483         esccor=0.0d0
 484       endif
 485 !      print *,"Processor",myrank," computed Usccorr"
 486 !
 487 ! 12/1/95 Multi-body terms
 488 !
 489       n_corr=0
 490       n_corr1=0
 491       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 492           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 493          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 494 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 495 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 496       else
 497          ecorr=0.0d0
 498          ecorr5=0.0d0
 499          ecorr6=0.0d0
 500          eturn6=0.0d0
 501       endif
 502 !elwrite(iout,*) "in etotal",ipot
 503       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 504          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 505 !d         write (iout,*) "multibody_hb ecorr",ecorr
 506       endif
 507 !elwrite(iout,*) "afeter  multibody hb"
 508
 509 !      print *,"Processor",myrank," computed Ucorr"
 510 !
 511 ! If performing constraint dynamics, call the constraint energy
 512 !  after the equilibration time
 513       if(usampl.and.totT.gt.eq_time) then
 514 !elwrite(iout,*) "afeter  multibody hb"
 515          call EconstrQ
 516 !elwrite(iout,*) "afeter  multibody hb"
 517          call Econstr_back
 518 !elwrite(iout,*) "afeter  multibody hb"
 519       else
 520          Uconst=0.0d0
 521          Uconst_back=0.0d0
 522       endif
 523       call flush(iout)
 524 !         write(iout,*) "after Econstr"
 525
 526       if (wliptran.gt.0) then
 527 !        print *,"PRZED WYWOLANIEM"
 528         call Eliptransfer(eliptran)
 529       else
 530        eliptran=0.0d0
 531       endif
 532       if (fg_rank.eq.0) then
 533       if (AFMlog.gt.0) then
 534         call AFMforce(Eafmforce)
 535       else if (selfguide.gt.0) then
 536         call AFMvel(Eafmforce)
 537       endif
 538       endif
 539       if (tubemode.eq.1) then
 540        call calctube(etube)
 541       else if (tubemode.eq.2) then
 542        call calctube2(etube)
 543       elseif (tubemode.eq.3) then
 544        call calcnano(etube)
 545       else
 546        etube=0.0d0
 547       endif
 548 !--------------------------------------------------------
 549       call ebond_nucl(estr_nucl)
 550       call ebend_nucl(ebe_nucl)
 551       call etor_nucl(etors_nucl)
 552       print *,"after ebend", ebe_nucl
 553 #ifdef TIMING
 554       time_enecalc=time_enecalc+MPI_Wtime()-time00
 555 #endif
 556 !      print *,"Processor",myrank," computed Uconstr"
 557 #ifdef TIMING
 558       time00=MPI_Wtime()
 559 #endif
 560 !
 561 ! Sum the energies
 562 !
 563       energia(1)=evdw
 564 #ifdef SCP14
 565       energia(2)=evdw2-evdw2_14
 566       energia(18)=evdw2_14
 567 #else
 568       energia(2)=evdw2
 569       energia(18)=0.0d0
 570 #endif
 571 #ifdef SPLITELE
 572       energia(3)=ees
 573       energia(16)=evdw1
 574 #else
 575       energia(3)=ees+evdw1
 576       energia(16)=0.0d0
 577 #endif
 578       energia(4)=ecorr
 579       energia(5)=ecorr5
 580       energia(6)=ecorr6
 581       energia(7)=eel_loc
 582       energia(8)=eello_turn3
 583       energia(9)=eello_turn4
 584       energia(10)=eturn6
 585       energia(11)=ebe
 586       energia(12)=escloc
 587       energia(13)=etors
 588       energia(14)=etors_d
 589       energia(15)=ehpb
 590       energia(19)=edihcnstr
 591       energia(17)=estr
 592       energia(20)=Uconst+Uconst_back
 593       energia(21)=esccor
 594       energia(22)=eliptran
 595       energia(23)=Eafmforce
 596       energia(24)=ethetacnstr
 597       energia(25)=etube
 598 !---------------------------------------------------------------
 599       energia(26)=evdwpp
 600       energia(27)=eespp
 601       energia(28)=evdwpsb
 602       energia(29)=eelpsb
 603       energia(30)=evdwsb
 604       energia(31)=eelsb
 605       energia(32)=estr_nucl
 606       energia(33)=ebe_nucl
 607       energia(34)=esbloc
 608       energia(35)=etors_nucl
 609       energia(36)=etors_d_nucl
 610       energia(37)=ecorr_nucl
 611       energia(38)=ecorr3_nucl
 612 !----------------------------------------------------------------------
 613 !    Here are the energies showed per procesor if the are more processors
 614 !    per molecule then we sum it up in sum_energy subroutine
 615 !      print *," Processor",myrank," calls SUM_ENERGY"
 616       call sum_energy(energia,.true.)
 617       if (dyn_ss) call dyn_set_nss
 618 !      print *," Processor",myrank," left SUM_ENERGY"
 619 #ifdef TIMING
 620       time_sumene=time_sumene+MPI_Wtime()-time00
 621 #endif
 622 !el        call enerprint(energia)
 623 !elwrite(iout,*)"finish etotal"
 624       return
 625       end subroutine etotal
 626 !-----------------------------------------------------------------------------
 627       subroutine sum_energy(energia,reduce)
 628 !      implicit real*8 (a-h,o-z)
 629 !      include 'DIMENSIONS'
 630 #ifndef ISNAN
 631       external proc_proc
 632 #ifdef WINPGI
 633 !MS$ATTRIBUTES C ::  proc_proc
 634 #endif
 635 #endif
 636 #ifdef MPI
 637       include "mpif.h"
 638 #endif
 639 !      include 'COMMON.SETUP'
 640 !      include 'COMMON.IOUNITS'
 641       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 642 !      include 'COMMON.FFIELD'
 643 !      include 'COMMON.DERIV'
 644 !      include 'COMMON.INTERACT'
 645 !      include 'COMMON.SBRIDGE'
 646 !      include 'COMMON.CHAIN'
 647 !      include 'COMMON.VAR'
 648 !      include 'COMMON.CONTROL'
 649 !      include 'COMMON.TIME1'
 650       logical :: reduce
 651       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 652       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 653       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 654         eliptran,etube, Eafmforce,ethetacnstr
 655       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 656                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 657                       ecorr3_nucl
 658
 659       integer :: i
 660 #ifdef MPI
 661       integer :: ierr
 662       real(kind=8) :: time00
 663       if (nfgtasks.gt.1 .and. reduce) then
 664
 665 #ifdef DEBUG
 666         write (iout,*) "energies before REDUCE"
 667         call enerprint(energia)
 668         call flush(iout)
 669 #endif
 670         do i=0,n_ene
 671           enebuff(i)=energia(i)
 672         enddo
 673         time00=MPI_Wtime()
 674         call MPI_Barrier(FG_COMM,IERR)
 675         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 676         time00=MPI_Wtime()
 677         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 678           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 679 #ifdef DEBUG
 680         write (iout,*) "energies after REDUCE"
 681         call enerprint(energia)
 682         call flush(iout)
 683 #endif
 684         time_Reduce=time_Reduce+MPI_Wtime()-time00
 685       endif
 686       if (fg_rank.eq.0) then
 687 #endif
 688       evdw=energia(1)
 689 #ifdef SCP14
 690       evdw2=energia(2)+energia(18)
 691       evdw2_14=energia(18)
 692 #else
 693       evdw2=energia(2)
 694 #endif
 695 #ifdef SPLITELE
 696       ees=energia(3)
 697       evdw1=energia(16)
 698 #else
 699       ees=energia(3)
 700       evdw1=0.0d0
 701 #endif
 702       ecorr=energia(4)
 703       ecorr5=energia(5)
 704       ecorr6=energia(6)
 705       eel_loc=energia(7)
 706       eello_turn3=energia(8)
 707       eello_turn4=energia(9)
 708       eturn6=energia(10)
 709       ebe=energia(11)
 710       escloc=energia(12)
 711       etors=energia(13)
 712       etors_d=energia(14)
 713       ehpb=energia(15)
 714       edihcnstr=energia(19)
 715       estr=energia(17)
 716       Uconst=energia(20)
 717       esccor=energia(21)
 718       eliptran=energia(22)
 719       Eafmforce=energia(23)
 720       ethetacnstr=energia(24)
 721       etube=energia(25)
 722       evdwpp=energia(26)
 723       eespp=energia(27)
 724       evdwpsb=energia(28)
 725       eelpsb=energia(29)
 726       evdwsb=energia(30)
 727       eelsb=energia(31)
 728       estr_nucl=energia(32)
 729       ebe_nucl=energia(33)
 730       esbloc=energia(34)
 731       etors_nucl=energia(35)
 732       etors_d_nucl=energia(36)
 733       ecorr_nucl=energia(37)
 734       ecorr3_nucl=energia(38)
 735
 736
 737 #ifdef SPLITELE
 738       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 739        +wang*ebe+wtor*etors+wscloc*escloc &
 740        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 741        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 742        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 743        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 744        +Eafmforce+ethetacnstr  &
 745        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 746        +wvdwpp*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 747        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 748        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl
 749 #else
 750       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 751        +wang*ebe+wtor*etors+wscloc*escloc &
 752        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 753        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 754        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 755        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 756        +Eafmforce+ethetacnstr &
 757        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 758        +wvdwpp*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 759        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 760        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl
 761 #endif
 762       energia(0)=etot
 763 ! detecting NaNQ
 764 #ifdef ISNAN
 765 #ifdef AIX
 766       if (isnan(etot).ne.0) energia(0)=1.0d+99
 767 #else
 768       if (isnan(etot)) energia(0)=1.0d+99
 769 #endif
 770 #else
 771       i=0
 772 #ifdef WINPGI
 773       idumm=proc_proc(etot,i)
 774 #else
 775       call proc_proc(etot,i)
 776 #endif
 777       if(i.eq.1)energia(0)=1.0d+99
 778 #endif
 779 #ifdef MPI
 780       endif
 781 #endif
 782 !      call enerprint(energia)
 783       call flush(iout)
 784       return
 785       end subroutine sum_energy
 786 !-----------------------------------------------------------------------------
 787       subroutine rescale_weights(t_bath)
 788 !      implicit real*8 (a-h,o-z)
 789 #ifdef MPI
 790       include 'mpif.h'
 791 #endif
 792 !      include 'DIMENSIONS'
 793 !      include 'COMMON.IOUNITS'
 794 !      include 'COMMON.FFIELD'
 795 !      include 'COMMON.SBRIDGE'
 796       real(kind=8) :: kfac=2.4d0
 797       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 798 !el local variables
 799       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 800       real(kind=8) :: T0=3.0d2
 801       integer :: ierror
 802 !      facT=temp0/t_bath
 803 !      facT=2*temp0/(t_bath+temp0)
 804       if (rescale_mode.eq.0) then
 805         facT(1)=1.0d0
 806         facT(2)=1.0d0
 807         facT(3)=1.0d0
 808         facT(4)=1.0d0
 809         facT(5)=1.0d0
 810         facT(6)=1.0d0
 811       else if (rescale_mode.eq.1) then
 812         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 813         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 814         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 815         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 816         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 817 #ifdef WHAM_RUN
 818 !#if defined(WHAM_RUN) || defined(CLUSTER)
 819 #if defined(FUNCTH)
 820 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 821         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 822 #elif defined(FUNCT)
 823         facT(6)=t_bath/T0
 824 #else
 825         facT(6)=1.0d0
 826 #endif
 827 #endif
 828       else if (rescale_mode.eq.2) then
 829         x=t_bath/temp0
 830         x2=x*x
 831         x3=x2*x
 832         x4=x3*x
 833         x5=x4*x
 834         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 835         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 836         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 837         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 838         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 839 #ifdef WHAM_RUN
 840 !#if defined(WHAM_RUN) || defined(CLUSTER)
 841 #if defined(FUNCTH)
 842         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 843 #elif defined(FUNCT)
 844         facT(6)=t_bath/T0
 845 #else
 846         facT(6)=1.0d0
 847 #endif
 848 #endif
 849       else
 850         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 851         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 852 #ifdef MPI
 853        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 854 #endif
 855        stop 555
 856       endif
 857       welec=weights(3)*fact(1)
 858       wcorr=weights(4)*fact(3)
 859       wcorr5=weights(5)*fact(4)
 860       wcorr6=weights(6)*fact(5)
 861       wel_loc=weights(7)*fact(2)
 862       wturn3=weights(8)*fact(2)
 863       wturn4=weights(9)*fact(3)
 864       wturn6=weights(10)*fact(5)
 865       wtor=weights(13)*fact(1)
 866       wtor_d=weights(14)*fact(2)
 867       wsccor=weights(21)*fact(1)
 868
 869       return
 870       end subroutine rescale_weights
 871 !-----------------------------------------------------------------------------
 872       subroutine enerprint(energia)
 873 !      implicit real*8 (a-h,o-z)
 874 !      include 'DIMENSIONS'
 875 !      include 'COMMON.IOUNITS'
 876 !      include 'COMMON.FFIELD'
 877 !      include 'COMMON.SBRIDGE'
 878 !      include 'COMMON.MD'
 879       real(kind=8) :: energia(0:n_ene)
 880 !el local variables
 881       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 882       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 883       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
 884        etube,ethetacnstr,Eafmforce
 885       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 886                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 887                       ecorr3_nucl
 888
 889       etot=energia(0)
 890       evdw=energia(1)
 891       evdw2=energia(2)
 892 #ifdef SCP14
 893       evdw2=energia(2)+energia(18)
 894 #else
 895       evdw2=energia(2)
 896 #endif
 897       ees=energia(3)
 898 #ifdef SPLITELE
 899       evdw1=energia(16)
 900 #endif
 901       ecorr=energia(4)
 902       ecorr5=energia(5)
 903       ecorr6=energia(6)
 904       eel_loc=energia(7)
 905       eello_turn3=energia(8)
 906       eello_turn4=energia(9)
 907       eello_turn6=energia(10)
 908       ebe=energia(11)
 909       escloc=energia(12)
 910       etors=energia(13)
 911       etors_d=energia(14)
 912       ehpb=energia(15)
 913       edihcnstr=energia(19)
 914       estr=energia(17)
 915       Uconst=energia(20)
 916       esccor=energia(21)
 917       eliptran=energia(22)
 918       Eafmforce=energia(23)
 919       ethetacnstr=energia(24)
 920       etube=energia(25)
 921       evdwpp=energia(26)
 922       eespp=energia(27)
 923       evdwpsb=energia(28)
 924       eelpsb=energia(29)
 925       evdwsb=energia(30)
 926       eelsb=energia(31)
 927       estr_nucl=energia(32)
 928       ebe_nucl=energia(33)
 929       esbloc=energia(34)
 930       etors_nucl=energia(35)
 931       etors_d_nucl=energia(36)
 932       ecorr_nucl=energia(37)
 933       ecorr3_nucl=energia(38)
 934
 935 #ifdef SPLITELE
 936       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
 937         estr,wbond,ebe,wang,&
 938         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 939         ecorr,wcorr,&
 940         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 941         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
 942         edihcnstr,ethetacnstr,ebr*nss,&
 943         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
 944         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
 945         evdwpp,wvdwpp,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
 946         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
 947         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
 948         ecorr3_nucl,wcorr3_nucl, &
 949         etot
 950    10 format (/'Virtual-chain energies:'// &
 951        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 952        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 953        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 954        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
 955        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 956        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 957        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 958        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 959        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 960        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 961        ' (SS bridges & dist. cnstr.)'/ &
 962        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 963        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 964        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 965        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 966        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 967        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 968        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 969        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 970        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 971        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
 972        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 973        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
 974        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
 975        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
 976        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
 977        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
 978        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
 979        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
 980        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
 981        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
 982        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
 983        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
 984        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
 985        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
 986        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
 987        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
 988        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
 989        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
 990        'ETOT=  ',1pE16.6,' (total)')
 991 #else
 992       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
 993         estr,wbond,ebe,wang,&
 994         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 995         ecorr,wcorr,&
 996         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 997         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
 998         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
 999         etube,wtube, &
1000         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1001         evdwpp,wvdwpp,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1002         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1003         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1004         ecorr3_nucl,wcorr3_nucl, &
1005         etot
1006    10 format (/'Virtual-chain energies:'// &
1007        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1008        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1009        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1010        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1011        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1012        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1013        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1014        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1015        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1016        ' (SS bridges & dist. cnstr.)'/ &
1017        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1018        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1019        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1020        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1021        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1022        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1023        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1024        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1025        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1026        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1027        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1028        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1029        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1030        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1031        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1032        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1033        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1034        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1035        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1036        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1037        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1038        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1039        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1040        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1041        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1042        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1043        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1044        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1045        'ETOT=  ',1pE16.6,' (total)')
1046 #endif
1047       return
1048       end subroutine enerprint
1049 !-----------------------------------------------------------------------------
1050       subroutine elj(evdw)
1051 !
1052 ! This subroutine calculates the interaction energy of nonbonded side chains
1053 ! assuming the LJ potential of interaction.
1054 !
1055 !      implicit real*8 (a-h,o-z)
1056 !      include 'DIMENSIONS'
1057       real(kind=8),parameter :: accur=1.0d-10
1058 !      include 'COMMON.GEO'
1059 !      include 'COMMON.VAR'
1060 !      include 'COMMON.LOCAL'
1061 !      include 'COMMON.CHAIN'
1062 !      include 'COMMON.DERIV'
1063 !      include 'COMMON.INTERACT'
1064 !      include 'COMMON.TORSION'
1065 !      include 'COMMON.SBRIDGE'
1066 !      include 'COMMON.NAMES'
1067 !      include 'COMMON.IOUNITS'
1068 !      include 'COMMON.CONTACTS'
1069       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1070       integer :: num_conti
1071 !el local variables
1072       integer :: i,itypi,iint,j,itypi1,itypj,k
1073       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1074       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1075       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1076
1077 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1078       evdw=0.0D0
1079 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1080 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1081 !      allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres)
1082 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))       !(3,maxconts,maxres)
1083
1084       do i=iatsc_s,iatsc_e
1085         itypi=iabs(itype(i,1))
1086         if (itypi.eq.ntyp1) cycle
1087         itypi1=iabs(itype(i+1,1))
1088         xi=c(1,nres+i)
1089         yi=c(2,nres+i)
1090         zi=c(3,nres+i)
1091 ! Change 12/1/95
1092         num_conti=0
1093 !
1094 ! Calculate SC interaction energy.
1095 !
1096         do iint=1,nint_gr(i)
1097 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1098 !d   &                  'iend=',iend(i,iint)
1099           do j=istart(i,iint),iend(i,iint)
1100             itypj=iabs(itype(j,1))
1101             if (itypj.eq.ntyp1) cycle
1102             xj=c(1,nres+j)-xi
1103             yj=c(2,nres+j)-yi
1104             zj=c(3,nres+j)-zi
1105 ! Change 12/1/95 to calculate four-body interactions
1106             rij=xj*xj+yj*yj+zj*zj
1107             rrij=1.0D0/rij
1108 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1109             eps0ij=eps(itypi,itypj)
1110             fac=rrij**expon2
1111             e1=fac*fac*aa_aq(itypi,itypj)
1112             e2=fac*bb_aq(itypi,itypj)
1113             evdwij=e1+e2
1114 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1115 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1116 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1117 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1118 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1119 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1120             evdw=evdw+evdwij
1121 !
1122 ! Calculate the components of the gradient in DC and X
1123 !
1124             fac=-rrij*(e1+evdwij)
1125             gg(1)=xj*fac
1126             gg(2)=yj*fac
1127             gg(3)=zj*fac
1128             do k=1,3
1129               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1130               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1131               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1132               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1133             enddo
1134 !grad            do k=i,j-1
1135 !grad              do l=1,3
1136 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1137 !grad              enddo
1138 !grad            enddo
1139 !
1140 ! 12/1/95, revised on 5/20/97
1141 !
1142 ! Calculate the contact function. The ith column of the array JCONT will
1143 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1144 ! greater than I). The arrays FACONT and GACONT will contain the values of
1145 ! the contact function and its derivative.
1146 !
1147 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1148 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1149 ! Uncomment next line, if the correlation interactions are contact function only
1150             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1151               rij=dsqrt(rij)
1152               sigij=sigma(itypi,itypj)
1153               r0ij=rs0(itypi,itypj)
1154 !
1155 ! Check whether the SC's are not too far to make a contact.
1156 !
1157               rcut=1.5d0*r0ij
1158               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1159 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1160 !
1161               if (fcont.gt.0.0D0) then
1162 ! If the SC-SC distance if close to sigma, apply spline.
1163 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1164 !Adam &             fcont1,fprimcont1)
1165 !Adam           fcont1=1.0d0-fcont1
1166 !Adam           if (fcont1.gt.0.0d0) then
1167 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1168 !Adam             fcont=fcont*fcont1
1169 !Adam           endif
1170 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1171 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1172 !ga             do k=1,3
1173 !ga               gg(k)=gg(k)*eps0ij
1174 !ga             enddo
1175 !ga             eps0ij=-evdwij*eps0ij
1176 ! Uncomment for AL's type of SC correlation interactions.
1177 !adam           eps0ij=-evdwij
1178                 num_conti=num_conti+1
1179                 jcont(num_conti,i)=j
1180                 facont(num_conti,i)=fcont*eps0ij
1181                 fprimcont=eps0ij*fprimcont/rij
1182                 fcont=expon*fcont
1183 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1184 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1185 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1186 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1187                 gacont(1,num_conti,i)=-fprimcont*xj
1188                 gacont(2,num_conti,i)=-fprimcont*yj
1189                 gacont(3,num_conti,i)=-fprimcont*zj
1190 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1191 !d              write (iout,'(2i3,3f10.5)')
1192 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1193               endif
1194             endif
1195           enddo      ! j
1196         enddo        ! iint
1197 ! Change 12/1/95
1198         num_cont(i)=num_conti
1199       enddo          ! i
1200       do i=1,nct
1201         do j=1,3
1202           gvdwc(j,i)=expon*gvdwc(j,i)
1203           gvdwx(j,i)=expon*gvdwx(j,i)
1204         enddo
1205       enddo
1206 !******************************************************************************
1207 !
1208 !                              N O T E !!!
1209 !
1210 ! To save time, the factor of EXPON has been extracted from ALL components
1211 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1212 ! use!
1213 !
1214 !******************************************************************************
1215       return
1216       end subroutine elj
1217 !-----------------------------------------------------------------------------
1218       subroutine eljk(evdw)
1219 !
1220 ! This subroutine calculates the interaction energy of nonbonded side chains
1221 ! assuming the LJK potential of interaction.
1222 !
1223 !      implicit real*8 (a-h,o-z)
1224 !      include 'DIMENSIONS'
1225 !      include 'COMMON.GEO'
1226 !      include 'COMMON.VAR'
1227 !      include 'COMMON.LOCAL'
1228 !      include 'COMMON.CHAIN'
1229 !      include 'COMMON.DERIV'
1230 !      include 'COMMON.INTERACT'
1231 !      include 'COMMON.IOUNITS'
1232 !      include 'COMMON.NAMES'
1233       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1234       logical :: scheck
1235 !el local variables
1236       integer :: i,iint,j,itypi,itypi1,k,itypj
1237       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1238       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1239
1240 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1241       evdw=0.0D0
1242       do i=iatsc_s,iatsc_e
1243         itypi=iabs(itype(i,1))
1244         if (itypi.eq.ntyp1) cycle
1245         itypi1=iabs(itype(i+1,1))
1246         xi=c(1,nres+i)
1247         yi=c(2,nres+i)
1248         zi=c(3,nres+i)
1249 !
1250 ! Calculate SC interaction energy.
1251 !
1252         do iint=1,nint_gr(i)
1253           do j=istart(i,iint),iend(i,iint)
1254             itypj=iabs(itype(j,1))
1255             if (itypj.eq.ntyp1) cycle
1256             xj=c(1,nres+j)-xi
1257             yj=c(2,nres+j)-yi
1258             zj=c(3,nres+j)-zi
1259             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1260             fac_augm=rrij**expon
1261             e_augm=augm(itypi,itypj)*fac_augm
1262             r_inv_ij=dsqrt(rrij)
1263             rij=1.0D0/r_inv_ij
1264             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1265             fac=r_shift_inv**expon
1266             e1=fac*fac*aa_aq(itypi,itypj)
1267             e2=fac*bb_aq(itypi,itypj)
1268             evdwij=e_augm+e1+e2
1269 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1270 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1271 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1272 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1273 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1274 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1275 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1276             evdw=evdw+evdwij
1277 !
1278 ! Calculate the components of the gradient in DC and X
1279 !
1280             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1281             gg(1)=xj*fac
1282             gg(2)=yj*fac
1283             gg(3)=zj*fac
1284             do k=1,3
1285               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1286               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1287               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1288               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1289             enddo
1290 !grad            do k=i,j-1
1291 !grad              do l=1,3
1292 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1293 !grad              enddo
1294 !grad            enddo
1295           enddo      ! j
1296         enddo        ! iint
1297       enddo          ! i
1298       do i=1,nct
1299         do j=1,3
1300           gvdwc(j,i)=expon*gvdwc(j,i)
1301           gvdwx(j,i)=expon*gvdwx(j,i)
1302         enddo
1303       enddo
1304       return
1305       end subroutine eljk
1306 !-----------------------------------------------------------------------------
1307       subroutine ebp(evdw)
1308 !
1309 ! This subroutine calculates the interaction energy of nonbonded side chains
1310 ! assuming the Berne-Pechukas potential of interaction.
1311 !
1312       use comm_srutu
1313       use calc_data
1314 !      implicit real*8 (a-h,o-z)
1315 !      include 'DIMENSIONS'
1316 !      include 'COMMON.GEO'
1317 !      include 'COMMON.VAR'
1318 !      include 'COMMON.LOCAL'
1319 !      include 'COMMON.CHAIN'
1320 !      include 'COMMON.DERIV'
1321 !      include 'COMMON.NAMES'
1322 !      include 'COMMON.INTERACT'
1323 !      include 'COMMON.IOUNITS'
1324 !      include 'COMMON.CALC'
1325       use comm_srutu
1326 !el      integer :: icall
1327 !el      common /srutu/ icall
1328 !     double precision rrsave(maxdim)
1329       logical :: lprn
1330 !el local variables
1331       integer :: iint,itypi,itypi1,itypj
1332       real(kind=8) :: rrij,xi,yi,zi
1333       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1334
1335 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1336       evdw=0.0D0
1337 !     if (icall.eq.0) then
1338 !       lprn=.true.
1339 !     else
1340         lprn=.false.
1341 !     endif
1342 !el      ind=0
1343       do i=iatsc_s,iatsc_e
1344         itypi=iabs(itype(i,1))
1345         if (itypi.eq.ntyp1) cycle
1346         itypi1=iabs(itype(i+1,1))
1347         xi=c(1,nres+i)
1348         yi=c(2,nres+i)
1349         zi=c(3,nres+i)
1350         dxi=dc_norm(1,nres+i)
1351         dyi=dc_norm(2,nres+i)
1352         dzi=dc_norm(3,nres+i)
1353 !        dsci_inv=dsc_inv(itypi)
1354         dsci_inv=vbld_inv(i+nres)
1355 !
1356 ! Calculate SC interaction energy.
1357 !
1358         do iint=1,nint_gr(i)
1359           do j=istart(i,iint),iend(i,iint)
1360 !el            ind=ind+1
1361             itypj=iabs(itype(j,1))
1362             if (itypj.eq.ntyp1) cycle
1363 !            dscj_inv=dsc_inv(itypj)
1364             dscj_inv=vbld_inv(j+nres)
1365             chi1=chi(itypi,itypj)
1366             chi2=chi(itypj,itypi)
1367             chi12=chi1*chi2
1368             chip1=chip(itypi)
1369             chip2=chip(itypj)
1370             chip12=chip1*chip2
1371             alf1=alp(itypi)
1372             alf2=alp(itypj)
1373             alf12=0.5D0*(alf1+alf2)
1374 ! For diagnostics only!!!
1375 !           chi1=0.0D0
1376 !           chi2=0.0D0
1377 !           chi12=0.0D0
1378 !           chip1=0.0D0
1379 !           chip2=0.0D0
1380 !           chip12=0.0D0
1381 !           alf1=0.0D0
1382 !           alf2=0.0D0
1383 !           alf12=0.0D0
1384             xj=c(1,nres+j)-xi
1385             yj=c(2,nres+j)-yi
1386             zj=c(3,nres+j)-zi
1387             dxj=dc_norm(1,nres+j)
1388             dyj=dc_norm(2,nres+j)
1389             dzj=dc_norm(3,nres+j)
1390             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1391 !d          if (icall.eq.0) then
1392 !d            rrsave(ind)=rrij
1393 !d          else
1394 !d            rrij=rrsave(ind)
1395 !d          endif
1396             rij=dsqrt(rrij)
1397 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1398             call sc_angular
1399 ! Calculate whole angle-dependent part of epsilon and contributions
1400 ! to its derivatives
1401             fac=(rrij*sigsq)**expon2
1402             e1=fac*fac*aa_aq(itypi,itypj)
1403             e2=fac*bb_aq(itypi,itypj)
1404             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1405             eps2der=evdwij*eps3rt
1406             eps3der=evdwij*eps2rt
1407             evdwij=evdwij*eps2rt*eps3rt
1408             evdw=evdw+evdwij
1409             if (lprn) then
1410             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1411             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1412 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1413 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1414 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1415 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1416 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1417 !d     &        evdwij
1418             endif
1419 ! Calculate gradient components.
1420             e1=e1*eps1*eps2rt**2*eps3rt**2
1421             fac=-expon*(e1+evdwij)
1422             sigder=fac/sigsq
1423             fac=rrij*fac
1424 ! Calculate radial part of the gradient
1425             gg(1)=xj*fac
1426             gg(2)=yj*fac
1427             gg(3)=zj*fac
1428 ! Calculate the angular part of the gradient and sum add the contributions
1429 ! to the appropriate components of the Cartesian gradient.
1430             call sc_grad
1431           enddo      ! j
1432         enddo        ! iint
1433       enddo          ! i
1434 !     stop
1435       return
1436       end subroutine ebp
1437 !-----------------------------------------------------------------------------
1438       subroutine egb(evdw)
1439 !
1440 ! This subroutine calculates the interaction energy of nonbonded side chains
1441 ! assuming the Gay-Berne potential of interaction.
1442 !
1443       use calc_data
1444 !      implicit real*8 (a-h,o-z)
1445 !      include 'DIMENSIONS'
1446 !      include 'COMMON.GEO'
1447 !      include 'COMMON.VAR'
1448 !      include 'COMMON.LOCAL'
1449 !      include 'COMMON.CHAIN'
1450 !      include 'COMMON.DERIV'
1451 !      include 'COMMON.NAMES'
1452 !      include 'COMMON.INTERACT'
1453 !      include 'COMMON.IOUNITS'
1454 !      include 'COMMON.CALC'
1455 !      include 'COMMON.CONTROL'
1456 !      include 'COMMON.SBRIDGE'
1457       logical :: lprn
1458 !el local variables
1459       integer :: iint,itypi,itypi1,itypj,subchap
1460       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1461       real(kind=8) :: evdw,sig0ij
1462       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1463                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1464                     sslipi,sslipj,faclip
1465       integer :: ii
1466       real(kind=8) :: fracinbuf
1467
1468 !cccc      energy_dec=.false.
1469 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1470       evdw=0.0D0
1471       lprn=.false.
1472 !     if (icall.eq.0) lprn=.false.
1473 !el      ind=0
1474       do i=iatsc_s,iatsc_e
1475 !C        print *,"I am in EVDW",i
1476         itypi=iabs(itype(i,1))
1477 !        if (i.ne.47) cycle
1478         if (itypi.eq.ntyp1) cycle
1479         itypi1=iabs(itype(i+1,1))
1480         xi=c(1,nres+i)
1481         yi=c(2,nres+i)
1482         zi=c(3,nres+i)
1483           xi=dmod(xi,boxxsize)
1484           if (xi.lt.0) xi=xi+boxxsize
1485           yi=dmod(yi,boxysize)
1486           if (yi.lt.0) yi=yi+boxysize
1487           zi=dmod(zi,boxzsize)
1488           if (zi.lt.0) zi=zi+boxzsize
1489
1490        if ((zi.gt.bordlipbot)  &
1491         .and.(zi.lt.bordliptop)) then
1492 !C the energy transfer exist
1493         if (zi.lt.buflipbot) then
1494 !C what fraction I am in
1495          fracinbuf=1.0d0-  &
1496               ((zi-bordlipbot)/lipbufthick)
1497 !C lipbufthick is thickenes of lipid buffore
1498          sslipi=sscalelip(fracinbuf)
1499          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1500         elseif (zi.gt.bufliptop) then
1501          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1502          sslipi=sscalelip(fracinbuf)
1503          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1504         else
1505          sslipi=1.0d0
1506          ssgradlipi=0.0
1507         endif
1508        else
1509          sslipi=0.0d0
1510          ssgradlipi=0.0
1511        endif
1512 !       print *, sslipi,ssgradlipi
1513         dxi=dc_norm(1,nres+i)
1514         dyi=dc_norm(2,nres+i)
1515         dzi=dc_norm(3,nres+i)
1516 !        dsci_inv=dsc_inv(itypi)
1517         dsci_inv=vbld_inv(i+nres)
1518 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1519 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1520 !
1521 ! Calculate SC interaction energy.
1522 !
1523         do iint=1,nint_gr(i)
1524           do j=istart(i,iint),iend(i,iint)
1525             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1526               call dyn_ssbond_ene(i,j,evdwij)
1527               evdw=evdw+evdwij
1528               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1529                               'evdw',i,j,evdwij,' ss'
1530 !              if (energy_dec) write (iout,*) &
1531 !                              'evdw',i,j,evdwij,' ss'
1532              do k=j+1,iend(i,iint)
1533 !C search over all next residues
1534               if (dyn_ss_mask(k)) then
1535 !C check if they are cysteins
1536 !C              write(iout,*) 'k=',k
1537
1538 !c              write(iout,*) "PRZED TRI", evdwij
1539 !               evdwij_przed_tri=evdwij
1540               call triple_ssbond_ene(i,j,k,evdwij)
1541 !c               if(evdwij_przed_tri.ne.evdwij) then
1542 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1543 !c               endif
1544
1545 !c              write(iout,*) "PO TRI", evdwij
1546 !C call the energy function that removes the artifical triple disulfide
1547 !C bond the soubroutine is located in ssMD.F
1548               evdw=evdw+evdwij
1549               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1550                             'evdw',i,j,evdwij,'tss'
1551               endif!dyn_ss_mask(k)
1552              enddo! k
1553             ELSE
1554 !el            ind=ind+1
1555             itypj=iabs(itype(j,1))
1556             if (itypj.eq.ntyp1) cycle
1557 !             if (j.ne.78) cycle
1558 !            dscj_inv=dsc_inv(itypj)
1559             dscj_inv=vbld_inv(j+nres)
1560 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1561 !              1.0d0/vbld(j+nres) !d
1562 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1563             sig0ij=sigma(itypi,itypj)
1564             chi1=chi(itypi,itypj)
1565             chi2=chi(itypj,itypi)
1566             chi12=chi1*chi2
1567             chip1=chip(itypi)
1568             chip2=chip(itypj)
1569             chip12=chip1*chip2
1570             alf1=alp(itypi)
1571             alf2=alp(itypj)
1572             alf12=0.5D0*(alf1+alf2)
1573 ! For diagnostics only!!!
1574 !           chi1=0.0D0
1575 !           chi2=0.0D0
1576 !           chi12=0.0D0
1577 !           chip1=0.0D0
1578 !           chip2=0.0D0
1579 !           chip12=0.0D0
1580 !           alf1=0.0D0
1581 !           alf2=0.0D0
1582 !           alf12=0.0D0
1583            xj=c(1,nres+j)
1584            yj=c(2,nres+j)
1585            zj=c(3,nres+j)
1586           xj=dmod(xj,boxxsize)
1587           if (xj.lt.0) xj=xj+boxxsize
1588           yj=dmod(yj,boxysize)
1589           if (yj.lt.0) yj=yj+boxysize
1590           zj=dmod(zj,boxzsize)
1591           if (zj.lt.0) zj=zj+boxzsize
1592 !          print *,"tu",xi,yi,zi,xj,yj,zj
1593 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1594 ! this fragment set correct epsilon for lipid phase
1595        if ((zj.gt.bordlipbot)  &
1596        .and.(zj.lt.bordliptop)) then
1597 !C the energy transfer exist
1598         if (zj.lt.buflipbot) then
1599 !C what fraction I am in
1600          fracinbuf=1.0d0-     &
1601              ((zj-bordlipbot)/lipbufthick)
1602 !C lipbufthick is thickenes of lipid buffore
1603          sslipj=sscalelip(fracinbuf)
1604          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1605         elseif (zj.gt.bufliptop) then
1606          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1607          sslipj=sscalelip(fracinbuf)
1608          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1609         else
1610          sslipj=1.0d0
1611          ssgradlipj=0.0
1612         endif
1613        else
1614          sslipj=0.0d0
1615          ssgradlipj=0.0
1616        endif
1617       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1618        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1619       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1620        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1621 !------------------------------------------------
1622       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1623       xj_safe=xj
1624       yj_safe=yj
1625       zj_safe=zj
1626       subchap=0
1627       do xshift=-1,1
1628       do yshift=-1,1
1629       do zshift=-1,1
1630           xj=xj_safe+xshift*boxxsize
1631           yj=yj_safe+yshift*boxysize
1632           zj=zj_safe+zshift*boxzsize
1633           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1634           if(dist_temp.lt.dist_init) then
1635             dist_init=dist_temp
1636             xj_temp=xj
1637             yj_temp=yj
1638             zj_temp=zj
1639             subchap=1
1640           endif
1641        enddo
1642        enddo
1643        enddo
1644        if (subchap.eq.1) then
1645           xj=xj_temp-xi
1646           yj=yj_temp-yi
1647           zj=zj_temp-zi
1648        else
1649           xj=xj_safe-xi
1650           yj=yj_safe-yi
1651           zj=zj_safe-zi
1652        endif
1653             dxj=dc_norm(1,nres+j)
1654             dyj=dc_norm(2,nres+j)
1655             dzj=dc_norm(3,nres+j)
1656 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1657 !            write (iout,*) "j",j," dc_norm",& !d
1658 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1659 !          write(iout,*)"rrij ",rrij
1660 !          write(iout,*)"xj yj zj ", xj, yj, zj
1661 !          write(iout,*)"xi yi zi ", xi, yi, zi
1662 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1663             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1664             rij=dsqrt(rrij)
1665             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1666             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1667 !            print *,sss_ele_cut,sss_ele_grad,&
1668 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1669             if (sss_ele_cut.le.0.0) cycle
1670 ! Calculate angle-dependent terms of energy and contributions to their
1671 ! derivatives.
1672             call sc_angular
1673             sigsq=1.0D0/sigsq
1674             sig=sig0ij*dsqrt(sigsq)
1675             rij_shift=1.0D0/rij-sig+sig0ij
1676 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1677 !            "sig0ij",sig0ij
1678 ! for diagnostics; uncomment
1679 !            rij_shift=1.2*sig0ij
1680 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1681             if (rij_shift.le.0.0D0) then
1682               evdw=1.0D20
1683 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1684 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1685 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1686               return
1687             endif
1688             sigder=-sig*sigsq
1689 !---------------------------------------------------------------
1690             rij_shift=1.0D0/rij_shift
1691             fac=rij_shift**expon
1692             faclip=fac
1693             e1=fac*fac*aa!(itypi,itypj)
1694             e2=fac*bb!(itypi,itypj)
1695             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1696             eps2der=evdwij*eps3rt
1697             eps3der=evdwij*eps2rt
1698 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1699 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1700 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1701             evdwij=evdwij*eps2rt*eps3rt
1702             evdw=evdw+evdwij*sss_ele_cut
1703             if (lprn) then
1704             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1705             epsi=bb**2/aa!(itypi,itypj)
1706             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1707               restyp(itypi,1),i,restyp(itypj,1),j, &
1708               epsi,sigm,chi1,chi2,chip1,chip2, &
1709               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1710               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1711               evdwij
1712             endif
1713
1714             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1715                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1716 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1717 !            if (energy_dec) write (iout,*) &
1718 !                             'evdw',i,j,evdwij
1719 !                       print *,"ZALAMKA", evdw
1720
1721 ! Calculate gradient components.
1722             e1=e1*eps1*eps2rt**2*eps3rt**2
1723             fac=-expon*(e1+evdwij)*rij_shift
1724             sigder=fac*sigder
1725             fac=rij*fac
1726 !            print *,'before fac',fac,rij,evdwij
1727             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1728             /sigma(itypi,itypj)*rij
1729 !            print *,'grad part scale',fac,   &
1730 !             evdwij*sss_ele_grad/sss_ele_cut &
1731 !            /sigma(itypi,itypj)*rij
1732 !            fac=0.0d0
1733 ! Calculate the radial part of the gradient
1734             gg(1)=xj*fac
1735             gg(2)=yj*fac
1736             gg(3)=zj*fac
1737 !C Calculate the radial part of the gradient
1738             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1739        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1740         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1741        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1742             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1743             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1744
1745 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1746 ! Calculate angular part of the gradient.
1747             call sc_grad
1748             ENDIF    ! dyn_ss
1749           enddo      ! j
1750         enddo        ! iint
1751       enddo          ! i
1752 !       print *,"ZALAMKA", evdw
1753 !      write (iout,*) "Number of loop steps in EGB:",ind
1754 !ccc      energy_dec=.false.
1755       return
1756       end subroutine egb
1757 !-----------------------------------------------------------------------------
1758       subroutine egbv(evdw)
1759 !
1760 ! This subroutine calculates the interaction energy of nonbonded side chains
1761 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1762 !
1763       use comm_srutu
1764       use calc_data
1765 !      implicit real*8 (a-h,o-z)
1766 !      include 'DIMENSIONS'
1767 !      include 'COMMON.GEO'
1768 !      include 'COMMON.VAR'
1769 !      include 'COMMON.LOCAL'
1770 !      include 'COMMON.CHAIN'
1771 !      include 'COMMON.DERIV'
1772 !      include 'COMMON.NAMES'
1773 !      include 'COMMON.INTERACT'
1774 !      include 'COMMON.IOUNITS'
1775 !      include 'COMMON.CALC'
1776       use comm_srutu
1777 !el      integer :: icall
1778 !el      common /srutu/ icall
1779       logical :: lprn
1780 !el local variables
1781       integer :: iint,itypi,itypi1,itypj
1782       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1783       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1784
1785 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1786       evdw=0.0D0
1787       lprn=.false.
1788 !     if (icall.eq.0) lprn=.true.
1789 !el      ind=0
1790       do i=iatsc_s,iatsc_e
1791         itypi=iabs(itype(i,1))
1792         if (itypi.eq.ntyp1) cycle
1793         itypi1=iabs(itype(i+1,1))
1794         xi=c(1,nres+i)
1795         yi=c(2,nres+i)
1796         zi=c(3,nres+i)
1797         dxi=dc_norm(1,nres+i)
1798         dyi=dc_norm(2,nres+i)
1799         dzi=dc_norm(3,nres+i)
1800 !        dsci_inv=dsc_inv(itypi)
1801         dsci_inv=vbld_inv(i+nres)
1802 !
1803 ! Calculate SC interaction energy.
1804 !
1805         do iint=1,nint_gr(i)
1806           do j=istart(i,iint),iend(i,iint)
1807 !el            ind=ind+1
1808             itypj=iabs(itype(j,1))
1809             if (itypj.eq.ntyp1) cycle
1810 !            dscj_inv=dsc_inv(itypj)
1811             dscj_inv=vbld_inv(j+nres)
1812             sig0ij=sigma(itypi,itypj)
1813             r0ij=r0(itypi,itypj)
1814             chi1=chi(itypi,itypj)
1815             chi2=chi(itypj,itypi)
1816             chi12=chi1*chi2
1817             chip1=chip(itypi)
1818             chip2=chip(itypj)
1819             chip12=chip1*chip2
1820             alf1=alp(itypi)
1821             alf2=alp(itypj)
1822             alf12=0.5D0*(alf1+alf2)
1823 ! For diagnostics only!!!
1824 !           chi1=0.0D0
1825 !           chi2=0.0D0
1826 !           chi12=0.0D0
1827 !           chip1=0.0D0
1828 !           chip2=0.0D0
1829 !           chip12=0.0D0
1830 !           alf1=0.0D0
1831 !           alf2=0.0D0
1832 !           alf12=0.0D0
1833             xj=c(1,nres+j)-xi
1834             yj=c(2,nres+j)-yi
1835             zj=c(3,nres+j)-zi
1836             dxj=dc_norm(1,nres+j)
1837             dyj=dc_norm(2,nres+j)
1838             dzj=dc_norm(3,nres+j)
1839             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1840             rij=dsqrt(rrij)
1841 ! Calculate angle-dependent terms of energy and contributions to their
1842 ! derivatives.
1843             call sc_angular
1844             sigsq=1.0D0/sigsq
1845             sig=sig0ij*dsqrt(sigsq)
1846             rij_shift=1.0D0/rij-sig+r0ij
1847 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1848             if (rij_shift.le.0.0D0) then
1849               evdw=1.0D20
1850               return
1851             endif
1852             sigder=-sig*sigsq
1853 !---------------------------------------------------------------
1854             rij_shift=1.0D0/rij_shift
1855             fac=rij_shift**expon
1856             e1=fac*fac*aa_aq(itypi,itypj)
1857             e2=fac*bb_aq(itypi,itypj)
1858             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1859             eps2der=evdwij*eps3rt
1860             eps3der=evdwij*eps2rt
1861             fac_augm=rrij**expon
1862             e_augm=augm(itypi,itypj)*fac_augm
1863             evdwij=evdwij*eps2rt*eps3rt
1864             evdw=evdw+evdwij+e_augm
1865             if (lprn) then
1866             sigm=dabs(aa_aq(itypi,itypj)/&
1867             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1868             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1869             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1870               restyp(itypi,1),i,restyp(itypj,1),j,&
1871               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1872               chi1,chi2,chip1,chip2,&
1873               eps1,eps2rt**2,eps3rt**2,&
1874               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1875               evdwij+e_augm
1876             endif
1877 ! Calculate gradient components.
1878             e1=e1*eps1*eps2rt**2*eps3rt**2
1879             fac=-expon*(e1+evdwij)*rij_shift
1880             sigder=fac*sigder
1881             fac=rij*fac-2*expon*rrij*e_augm
1882 ! Calculate the radial part of the gradient
1883             gg(1)=xj*fac
1884             gg(2)=yj*fac
1885             gg(3)=zj*fac
1886 ! Calculate angular part of the gradient.
1887             call sc_grad
1888           enddo      ! j
1889         enddo        ! iint
1890       enddo          ! i
1891       end subroutine egbv
1892 !-----------------------------------------------------------------------------
1893 !el      subroutine sc_angular in module geometry
1894 !-----------------------------------------------------------------------------
1895       subroutine e_softsphere(evdw)
1896 !
1897 ! This subroutine calculates the interaction energy of nonbonded side chains
1898 ! assuming the LJ potential of interaction.
1899 !
1900 !      implicit real*8 (a-h,o-z)
1901 !      include 'DIMENSIONS'
1902       real(kind=8),parameter :: accur=1.0d-10
1903 !      include 'COMMON.GEO'
1904 !      include 'COMMON.VAR'
1905 !      include 'COMMON.LOCAL'
1906 !      include 'COMMON.CHAIN'
1907 !      include 'COMMON.DERIV'
1908 !      include 'COMMON.INTERACT'
1909 !      include 'COMMON.TORSION'
1910 !      include 'COMMON.SBRIDGE'
1911 !      include 'COMMON.NAMES'
1912 !      include 'COMMON.IOUNITS'
1913 !      include 'COMMON.CONTACTS'
1914       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1915 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1916 !el local variables
1917       integer :: i,iint,j,itypi,itypi1,itypj,k
1918       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1919       real(kind=8) :: fac
1920
1921       evdw=0.0D0
1922       do i=iatsc_s,iatsc_e
1923         itypi=iabs(itype(i,1))
1924         if (itypi.eq.ntyp1) cycle
1925         itypi1=iabs(itype(i+1,1))
1926         xi=c(1,nres+i)
1927         yi=c(2,nres+i)
1928         zi=c(3,nres+i)
1929 !
1930 ! Calculate SC interaction energy.
1931 !
1932         do iint=1,nint_gr(i)
1933 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1934 !d   &                  'iend=',iend(i,iint)
1935           do j=istart(i,iint),iend(i,iint)
1936             itypj=iabs(itype(j,1))
1937             if (itypj.eq.ntyp1) cycle
1938             xj=c(1,nres+j)-xi
1939             yj=c(2,nres+j)-yi
1940             zj=c(3,nres+j)-zi
1941             rij=xj*xj+yj*yj+zj*zj
1942 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1943             r0ij=r0(itypi,itypj)
1944             r0ijsq=r0ij*r0ij
1945 !            print *,i,j,r0ij,dsqrt(rij)
1946             if (rij.lt.r0ijsq) then
1947               evdwij=0.25d0*(rij-r0ijsq)**2
1948               fac=rij-r0ijsq
1949             else
1950               evdwij=0.0d0
1951               fac=0.0d0
1952             endif
1953             evdw=evdw+evdwij
1954 !
1955 ! Calculate the components of the gradient in DC and X
1956 !
1957             gg(1)=xj*fac
1958             gg(2)=yj*fac
1959             gg(3)=zj*fac
1960             do k=1,3
1961               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1962               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1963               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1964               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1965             enddo
1966 !grad            do k=i,j-1
1967 !grad              do l=1,3
1968 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1969 !grad              enddo
1970 !grad            enddo
1971           enddo ! j
1972         enddo ! iint
1973       enddo ! i
1974       return
1975       end subroutine e_softsphere
1976 !-----------------------------------------------------------------------------
1977       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1978 !
1979 ! Soft-sphere potential of p-p interaction
1980 !
1981 !      implicit real*8 (a-h,o-z)
1982 !      include 'DIMENSIONS'
1983 !      include 'COMMON.CONTROL'
1984 !      include 'COMMON.IOUNITS'
1985 !      include 'COMMON.GEO'
1986 !      include 'COMMON.VAR'
1987 !      include 'COMMON.LOCAL'
1988 !      include 'COMMON.CHAIN'
1989 !      include 'COMMON.DERIV'
1990 !      include 'COMMON.INTERACT'
1991 !      include 'COMMON.CONTACTS'
1992 !      include 'COMMON.TORSION'
1993 !      include 'COMMON.VECTORS'
1994 !      include 'COMMON.FFIELD'
1995       real(kind=8),dimension(3) :: ggg
1996 !d      write(iout,*) 'In EELEC_soft_sphere'
1997 !el local variables
1998       integer :: i,j,k,num_conti,iteli,itelj
1999       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2000       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2001       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2002
2003       ees=0.0D0
2004       evdw1=0.0D0
2005       eel_loc=0.0d0
2006       eello_turn3=0.0d0
2007       eello_turn4=0.0d0
2008 !el      ind=0
2009       do i=iatel_s,iatel_e
2010         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2011         dxi=dc(1,i)
2012         dyi=dc(2,i)
2013         dzi=dc(3,i)
2014         xmedi=c(1,i)+0.5d0*dxi
2015         ymedi=c(2,i)+0.5d0*dyi
2016         zmedi=c(3,i)+0.5d0*dzi
2017         num_conti=0
2018 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2019         do j=ielstart(i),ielend(i)
2020           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2021 !el          ind=ind+1
2022           iteli=itel(i)
2023           itelj=itel(j)
2024           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2025           r0ij=rpp(iteli,itelj)
2026           r0ijsq=r0ij*r0ij
2027           dxj=dc(1,j)
2028           dyj=dc(2,j)
2029           dzj=dc(3,j)
2030           xj=c(1,j)+0.5D0*dxj-xmedi
2031           yj=c(2,j)+0.5D0*dyj-ymedi
2032           zj=c(3,j)+0.5D0*dzj-zmedi
2033           rij=xj*xj+yj*yj+zj*zj
2034           if (rij.lt.r0ijsq) then
2035             evdw1ij=0.25d0*(rij-r0ijsq)**2
2036             fac=rij-r0ijsq
2037           else
2038             evdw1ij=0.0d0
2039             fac=0.0d0
2040           endif
2041           evdw1=evdw1+evdw1ij
2042 !
2043 ! Calculate contributions to the Cartesian gradient.
2044 !
2045           ggg(1)=fac*xj
2046           ggg(2)=fac*yj
2047           ggg(3)=fac*zj
2048           do k=1,3
2049             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2050             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2051           enddo
2052 !
2053 ! Loop over residues i+1 thru j-1.
2054 !
2055 !grad          do k=i+1,j-1
2056 !grad            do l=1,3
2057 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2058 !grad            enddo
2059 !grad          enddo
2060         enddo ! j
2061       enddo   ! i
2062 !grad      do i=nnt,nct-1
2063 !grad        do k=1,3
2064 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2065 !grad        enddo
2066 !grad        do j=i+1,nct-1
2067 !grad          do k=1,3
2068 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2069 !grad          enddo
2070 !grad        enddo
2071 !grad      enddo
2072       return
2073       end subroutine eelec_soft_sphere
2074 !-----------------------------------------------------------------------------
2075       subroutine vec_and_deriv
2076 !      implicit real*8 (a-h,o-z)
2077 !      include 'DIMENSIONS'
2078 #ifdef MPI
2079       include 'mpif.h'
2080 #endif
2081 !      include 'COMMON.IOUNITS'
2082 !      include 'COMMON.GEO'
2083 !      include 'COMMON.VAR'
2084 !      include 'COMMON.LOCAL'
2085 !      include 'COMMON.CHAIN'
2086 !      include 'COMMON.VECTORS'
2087 !      include 'COMMON.SETUP'
2088 !      include 'COMMON.TIME1'
2089       real(kind=8),dimension(3,3,2) :: uyder,uzder
2090       real(kind=8),dimension(2) :: vbld_inv_temp
2091 ! Compute the local reference systems. For reference system (i), the
2092 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2093 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2094 !el local variables
2095       integer :: i,j,k,l
2096       real(kind=8) :: facy,fac,costh
2097
2098 #ifdef PARVEC
2099       do i=ivec_start,ivec_end
2100 #else
2101       do i=1,nres-1
2102 #endif
2103           if (i.eq.nres-1) then
2104 ! Case of the last full residue
2105 ! Compute the Z-axis
2106             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2107             costh=dcos(pi-theta(nres))
2108             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2109             do k=1,3
2110               uz(k,i)=fac*uz(k,i)
2111             enddo
2112 ! Compute the derivatives of uz
2113             uzder(1,1,1)= 0.0d0
2114             uzder(2,1,1)=-dc_norm(3,i-1)
2115             uzder(3,1,1)= dc_norm(2,i-1)
2116             uzder(1,2,1)= dc_norm(3,i-1)
2117             uzder(2,2,1)= 0.0d0
2118             uzder(3,2,1)=-dc_norm(1,i-1)
2119             uzder(1,3,1)=-dc_norm(2,i-1)
2120             uzder(2,3,1)= dc_norm(1,i-1)
2121             uzder(3,3,1)= 0.0d0
2122             uzder(1,1,2)= 0.0d0
2123             uzder(2,1,2)= dc_norm(3,i)
2124             uzder(3,1,2)=-dc_norm(2,i)
2125             uzder(1,2,2)=-dc_norm(3,i)
2126             uzder(2,2,2)= 0.0d0
2127             uzder(3,2,2)= dc_norm(1,i)
2128             uzder(1,3,2)= dc_norm(2,i)
2129             uzder(2,3,2)=-dc_norm(1,i)
2130             uzder(3,3,2)= 0.0d0
2131 ! Compute the Y-axis
2132             facy=fac
2133             do k=1,3
2134               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2135             enddo
2136 ! Compute the derivatives of uy
2137             do j=1,3
2138               do k=1,3
2139                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2140                               -dc_norm(k,i)*dc_norm(j,i-1)
2141                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2142               enddo
2143               uyder(j,j,1)=uyder(j,j,1)-costh
2144               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2145             enddo
2146             do j=1,2
2147               do k=1,3
2148                 do l=1,3
2149                   uygrad(l,k,j,i)=uyder(l,k,j)
2150                   uzgrad(l,k,j,i)=uzder(l,k,j)
2151                 enddo
2152               enddo
2153             enddo
2154             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2155             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2156             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2157             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2158           else
2159 ! Other residues
2160 ! Compute the Z-axis
2161             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2162             costh=dcos(pi-theta(i+2))
2163             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2164             do k=1,3
2165               uz(k,i)=fac*uz(k,i)
2166             enddo
2167 ! Compute the derivatives of uz
2168             uzder(1,1,1)= 0.0d0
2169             uzder(2,1,1)=-dc_norm(3,i+1)
2170             uzder(3,1,1)= dc_norm(2,i+1)
2171             uzder(1,2,1)= dc_norm(3,i+1)
2172             uzder(2,2,1)= 0.0d0
2173             uzder(3,2,1)=-dc_norm(1,i+1)
2174             uzder(1,3,1)=-dc_norm(2,i+1)
2175             uzder(2,3,1)= dc_norm(1,i+1)
2176             uzder(3,3,1)= 0.0d0
2177             uzder(1,1,2)= 0.0d0
2178             uzder(2,1,2)= dc_norm(3,i)
2179             uzder(3,1,2)=-dc_norm(2,i)
2180             uzder(1,2,2)=-dc_norm(3,i)
2181             uzder(2,2,2)= 0.0d0
2182             uzder(3,2,2)= dc_norm(1,i)
2183             uzder(1,3,2)= dc_norm(2,i)
2184             uzder(2,3,2)=-dc_norm(1,i)
2185             uzder(3,3,2)= 0.0d0
2186 ! Compute the Y-axis
2187             facy=fac
2188             do k=1,3
2189               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2190             enddo
2191 ! Compute the derivatives of uy
2192             do j=1,3
2193               do k=1,3
2194                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2195                               -dc_norm(k,i)*dc_norm(j,i+1)
2196                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2197               enddo
2198               uyder(j,j,1)=uyder(j,j,1)-costh
2199               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2200             enddo
2201             do j=1,2
2202               do k=1,3
2203                 do l=1,3
2204                   uygrad(l,k,j,i)=uyder(l,k,j)
2205                   uzgrad(l,k,j,i)=uzder(l,k,j)
2206                 enddo
2207               enddo
2208             enddo
2209             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2210             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2211             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2212             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2213           endif
2214       enddo
2215       do i=1,nres-1
2216         vbld_inv_temp(1)=vbld_inv(i+1)
2217         if (i.lt.nres-1) then
2218           vbld_inv_temp(2)=vbld_inv(i+2)
2219           else
2220           vbld_inv_temp(2)=vbld_inv(i)
2221           endif
2222         do j=1,2
2223           do k=1,3
2224             do l=1,3
2225               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2226               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2227             enddo
2228           enddo
2229         enddo
2230       enddo
2231 #if defined(PARVEC) && defined(MPI)
2232       if (nfgtasks1.gt.1) then
2233         time00=MPI_Wtime()
2234 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2235 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2236 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2237         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2238          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2239          FG_COMM1,IERR)
2240         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2241          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2242          FG_COMM1,IERR)
2243         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2244          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2245          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2246         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2247          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2248          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2249         time_gather=time_gather+MPI_Wtime()-time00
2250       endif
2251 !      if (fg_rank.eq.0) then
2252 !        write (iout,*) "Arrays UY and UZ"
2253 !        do i=1,nres-1
2254 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2255 !     &     (uz(k,i),k=1,3)
2256 !        enddo
2257 !      endif
2258 #endif
2259       return
2260       end subroutine vec_and_deriv
2261 !-----------------------------------------------------------------------------
2262       subroutine check_vecgrad
2263 !      implicit real*8 (a-h,o-z)
2264 !      include 'DIMENSIONS'
2265 !      include 'COMMON.IOUNITS'
2266 !      include 'COMMON.GEO'
2267 !      include 'COMMON.VAR'
2268 !      include 'COMMON.LOCAL'
2269 !      include 'COMMON.CHAIN'
2270 !      include 'COMMON.VECTORS'
2271       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt     !(3,3,2,maxres)
2272       real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
2273       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2274       real(kind=8),dimension(3) :: erij
2275       real(kind=8) :: delta=1.0d-7
2276 !el local variables
2277       integer :: i,j,k,l
2278
2279       call vec_and_deriv
2280 !d      do i=1,nres
2281 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2282 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2283 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2284 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2285 !d     &     (dc_norm(if90,i),if90=1,3)
2286 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2287 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2288 !d          write(iout,'(a)')
2289 !d      enddo
2290       do i=1,nres
2291         do j=1,2
2292           do k=1,3
2293             do l=1,3
2294               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2295               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2296             enddo
2297           enddo
2298         enddo
2299       enddo
2300       call vec_and_deriv
2301       do i=1,nres
2302         do j=1,3
2303           uyt(j,i)=uy(j,i)
2304           uzt(j,i)=uz(j,i)
2305         enddo
2306       enddo
2307       do i=1,nres
2308 !d        write (iout,*) 'i=',i
2309         do k=1,3
2310           erij(k)=dc_norm(k,i)
2311         enddo
2312         do j=1,3
2313           do k=1,3
2314             dc_norm(k,i)=erij(k)
2315           enddo
2316           dc_norm(j,i)=dc_norm(j,i)+delta
2317 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2318 !          do k=1,3
2319 !            dc_norm(k,i)=dc_norm(k,i)/fac
2320 !          enddo
2321 !          write (iout,*) (dc_norm(k,i),k=1,3)
2322 !          write (iout,*) (erij(k),k=1,3)
2323           call vec_and_deriv
2324           do k=1,3
2325             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2326             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2327             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2328             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2329           enddo
2330 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2331 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2332 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2333         enddo
2334         do k=1,3
2335           dc_norm(k,i)=erij(k)
2336         enddo
2337 !d        do k=1,3
2338 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2339 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2340 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2341 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2342 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2343 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2344 !d          write (iout,'(a)')
2345 !d        enddo
2346       enddo
2347       return
2348       end subroutine check_vecgrad
2349 !-----------------------------------------------------------------------------
2350       subroutine set_matrices
2351 !      implicit real*8 (a-h,o-z)
2352 !      include 'DIMENSIONS'
2353 #ifdef MPI
2354       include "mpif.h"
2355 !      include "COMMON.SETUP"
2356       integer :: IERR
2357       integer :: status(MPI_STATUS_SIZE)
2358 #endif
2359 !      include 'COMMON.IOUNITS'
2360 !      include 'COMMON.GEO'
2361 !      include 'COMMON.VAR'
2362 !      include 'COMMON.LOCAL'
2363 !      include 'COMMON.CHAIN'
2364 !      include 'COMMON.DERIV'
2365 !      include 'COMMON.INTERACT'
2366 !      include 'COMMON.CONTACTS'
2367 !      include 'COMMON.TORSION'
2368 !      include 'COMMON.VECTORS'
2369 !      include 'COMMON.FFIELD'
2370       real(kind=8) :: auxvec(2),auxmat(2,2)
2371       integer :: i,iti1,iti,k,l
2372       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2373 !       print *,"in set matrices"
2374 !
2375 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2376 ! to calculate the el-loc multibody terms of various order.
2377 !
2378 !AL el      mu=0.0d0
2379 #ifdef PARMAT
2380       do i=ivec_start+2,ivec_end+2
2381 #else
2382       do i=3,nres+1
2383 #endif
2384 !      print *,i,"i"
2385         if (i .lt. nres+1) then
2386           sin1=dsin(phi(i))
2387           cos1=dcos(phi(i))
2388           sintab(i-2)=sin1
2389           costab(i-2)=cos1
2390           obrot(1,i-2)=cos1
2391           obrot(2,i-2)=sin1
2392           sin2=dsin(2*phi(i))
2393           cos2=dcos(2*phi(i))
2394           sintab2(i-2)=sin2
2395           costab2(i-2)=cos2
2396           obrot2(1,i-2)=cos2
2397           obrot2(2,i-2)=sin2
2398           Ug(1,1,i-2)=-cos1
2399           Ug(1,2,i-2)=-sin1
2400           Ug(2,1,i-2)=-sin1
2401           Ug(2,2,i-2)= cos1
2402           Ug2(1,1,i-2)=-cos2
2403           Ug2(1,2,i-2)=-sin2
2404           Ug2(2,1,i-2)=-sin2
2405           Ug2(2,2,i-2)= cos2
2406         else
2407           costab(i-2)=1.0d0
2408           sintab(i-2)=0.0d0
2409           obrot(1,i-2)=1.0d0
2410           obrot(2,i-2)=0.0d0
2411           obrot2(1,i-2)=0.0d0
2412           obrot2(2,i-2)=0.0d0
2413           Ug(1,1,i-2)=1.0d0
2414           Ug(1,2,i-2)=0.0d0
2415           Ug(2,1,i-2)=0.0d0
2416           Ug(2,2,i-2)=1.0d0
2417           Ug2(1,1,i-2)=0.0d0
2418           Ug2(1,2,i-2)=0.0d0
2419           Ug2(2,1,i-2)=0.0d0
2420           Ug2(2,2,i-2)=0.0d0
2421         endif
2422         if (i .gt. 3 .and. i .lt. nres+1) then
2423           obrot_der(1,i-2)=-sin1
2424           obrot_der(2,i-2)= cos1
2425           Ugder(1,1,i-2)= sin1
2426           Ugder(1,2,i-2)=-cos1
2427           Ugder(2,1,i-2)=-cos1
2428           Ugder(2,2,i-2)=-sin1
2429           dwacos2=cos2+cos2
2430           dwasin2=sin2+sin2
2431           obrot2_der(1,i-2)=-dwasin2
2432           obrot2_der(2,i-2)= dwacos2
2433           Ug2der(1,1,i-2)= dwasin2
2434           Ug2der(1,2,i-2)=-dwacos2
2435           Ug2der(2,1,i-2)=-dwacos2
2436           Ug2der(2,2,i-2)=-dwasin2
2437         else
2438           obrot_der(1,i-2)=0.0d0
2439           obrot_der(2,i-2)=0.0d0
2440           Ugder(1,1,i-2)=0.0d0
2441           Ugder(1,2,i-2)=0.0d0
2442           Ugder(2,1,i-2)=0.0d0
2443           Ugder(2,2,i-2)=0.0d0
2444           obrot2_der(1,i-2)=0.0d0
2445           obrot2_der(2,i-2)=0.0d0
2446           Ug2der(1,1,i-2)=0.0d0
2447           Ug2der(1,2,i-2)=0.0d0
2448           Ug2der(2,1,i-2)=0.0d0
2449           Ug2der(2,2,i-2)=0.0d0
2450         endif
2451 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2452         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2453           iti = itortyp(itype(i-2,1))
2454         else
2455           iti=ntortyp+1
2456         endif
2457 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2458         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2459           iti1 = itortyp(itype(i-1,1))
2460         else
2461           iti1=ntortyp+1
2462         endif
2463 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2464 !d        write (iout,*) '*******i',i,' iti1',iti
2465 !d        write (iout,*) 'b1',b1(:,iti)
2466 !d        write (iout,*) 'b2',b2(:,iti)
2467 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2468 !        if (i .gt. iatel_s+2) then
2469         if (i .gt. nnt+2) then
2470           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2471           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2472           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2473           then
2474           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2475           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2476           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2477           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2478           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2479           endif
2480         else
2481           do k=1,2
2482             Ub2(k,i-2)=0.0d0
2483             Ctobr(k,i-2)=0.0d0
2484             Dtobr2(k,i-2)=0.0d0
2485             do l=1,2
2486               EUg(l,k,i-2)=0.0d0
2487               CUg(l,k,i-2)=0.0d0
2488               DUg(l,k,i-2)=0.0d0
2489               DtUg2(l,k,i-2)=0.0d0
2490             enddo
2491           enddo
2492         endif
2493         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2494         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2495         do k=1,2
2496           muder(k,i-2)=Ub2der(k,i-2)
2497         enddo
2498 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2499         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2500           if (itype(i-1,1).le.ntyp) then
2501             iti1 = itortyp(itype(i-1,1))
2502           else
2503             iti1=ntortyp+1
2504           endif
2505         else
2506           iti1=ntortyp+1
2507         endif
2508         do k=1,2
2509           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2510         enddo
2511 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2512 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2513 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2514 !d        write (iout,*) 'mu1',mu1(:,i-2)
2515 !d        write (iout,*) 'mu2',mu2(:,i-2)
2516         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2517         then
2518         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2519         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2520         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2521         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2522         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2523 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2524         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2525         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2526         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2527         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2528         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2529         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2530         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2531         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2532         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2533         endif
2534       enddo
2535 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2536 ! The order of matrices is from left to right.
2537       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2538       then
2539 !      do i=max0(ivec_start,2),ivec_end
2540       do i=2,nres-1
2541         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2542         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2543         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2544         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2545         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2546         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2547         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2548         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2549       enddo
2550       endif
2551 #if defined(MPI) && defined(PARMAT)
2552 #ifdef DEBUG
2553 !      if (fg_rank.eq.0) then
2554         write (iout,*) "Arrays UG and UGDER before GATHER"
2555         do i=1,nres-1
2556           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2557            ((ug(l,k,i),l=1,2),k=1,2),&
2558            ((ugder(l,k,i),l=1,2),k=1,2)
2559         enddo
2560         write (iout,*) "Arrays UG2 and UG2DER"
2561         do i=1,nres-1
2562           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2563            ((ug2(l,k,i),l=1,2),k=1,2),&
2564            ((ug2der(l,k,i),l=1,2),k=1,2)
2565         enddo
2566         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2567         do i=1,nres-1
2568           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2569            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2570            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2571         enddo
2572         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2573         do i=1,nres-1
2574           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2575            costab(i),sintab(i),costab2(i),sintab2(i)
2576         enddo
2577         write (iout,*) "Array MUDER"
2578         do i=1,nres-1
2579           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2580         enddo
2581 !      endif
2582 #endif
2583       if (nfgtasks.gt.1) then
2584         time00=MPI_Wtime()
2585 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2586 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2587 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2588 #ifdef MATGATHER
2589         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2590          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2591          FG_COMM1,IERR)
2592         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2593          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2594          FG_COMM1,IERR)
2595         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2596          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2597          FG_COMM1,IERR)
2598         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2599          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2600          FG_COMM1,IERR)
2601         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2602          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2603          FG_COMM1,IERR)
2604         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2605          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2606          FG_COMM1,IERR)
2607         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2608          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2609          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2610         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2611          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2612          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2613         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2614          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2615          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2616         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2617          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2618          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2619         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2620         then
2621         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2622          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2623          FG_COMM1,IERR)
2624         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2625          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2626          FG_COMM1,IERR)
2627         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2628          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2629          FG_COMM1,IERR)
2630        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2631          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2632          FG_COMM1,IERR)
2633         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2634          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2635          FG_COMM1,IERR)
2636         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2637          ivec_count(fg_rank1),&
2638          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2639          FG_COMM1,IERR)
2640         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2641          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2642          FG_COMM1,IERR)
2643         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2644          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2645          FG_COMM1,IERR)
2646         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2647          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2648          FG_COMM1,IERR)
2649         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2650          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2651          FG_COMM1,IERR)
2652         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2653          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2654          FG_COMM1,IERR)
2655         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2656          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2657          FG_COMM1,IERR)
2658         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2659          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2660          FG_COMM1,IERR)
2661         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2662          ivec_count(fg_rank1),&
2663          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2664          FG_COMM1,IERR)
2665         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2666          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2667          FG_COMM1,IERR)
2668        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2669          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2670          FG_COMM1,IERR)
2671         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2672          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2673          FG_COMM1,IERR)
2674        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2675          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2676          FG_COMM1,IERR)
2677         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2678          ivec_count(fg_rank1),&
2679          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2680          FG_COMM1,IERR)
2681         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2682          ivec_count(fg_rank1),&
2683          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2684          FG_COMM1,IERR)
2685         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2686          ivec_count(fg_rank1),&
2687          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2688          MPI_MAT2,FG_COMM1,IERR)
2689         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2690          ivec_count(fg_rank1),&
2691          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2692          MPI_MAT2,FG_COMM1,IERR)
2693         endif
2694 #else
2695 ! Passes matrix info through the ring
2696       isend=fg_rank1
2697       irecv=fg_rank1-1
2698       if (irecv.lt.0) irecv=nfgtasks1-1
2699       iprev=irecv
2700       inext=fg_rank1+1
2701       if (inext.ge.nfgtasks1) inext=0
2702       do i=1,nfgtasks1-1
2703 !        write (iout,*) "isend",isend," irecv",irecv
2704 !        call flush(iout)
2705         lensend=lentyp(isend)
2706         lenrecv=lentyp(irecv)
2707 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2708 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2709 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2710 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2711 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2712 !        write (iout,*) "Gather ROTAT1"
2713 !        call flush(iout)
2714 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2715 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2716 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2717 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2718 !        write (iout,*) "Gather ROTAT2"
2719 !        call flush(iout)
2720         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2721          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2722          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2723          iprev,4400+irecv,FG_COMM,status,IERR)
2724 !        write (iout,*) "Gather ROTAT_OLD"
2725 !        call flush(iout)
2726         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2727          MPI_PRECOMP11(lensend),inext,5500+isend,&
2728          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2729          iprev,5500+irecv,FG_COMM,status,IERR)
2730 !        write (iout,*) "Gather PRECOMP11"
2731 !        call flush(iout)
2732         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2733          MPI_PRECOMP12(lensend),inext,6600+isend,&
2734          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2735          iprev,6600+irecv,FG_COMM,status,IERR)
2736 !        write (iout,*) "Gather PRECOMP12"
2737 !        call flush(iout)
2738         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2739         then
2740         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2741          MPI_ROTAT2(lensend),inext,7700+isend,&
2742          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2743          iprev,7700+irecv,FG_COMM,status,IERR)
2744 !        write (iout,*) "Gather PRECOMP21"
2745 !        call flush(iout)
2746         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2747          MPI_PRECOMP22(lensend),inext,8800+isend,&
2748          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2749          iprev,8800+irecv,FG_COMM,status,IERR)
2750 !        write (iout,*) "Gather PRECOMP22"
2751 !        call flush(iout)
2752         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2753          MPI_PRECOMP23(lensend),inext,9900+isend,&
2754          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2755          MPI_PRECOMP23(lenrecv),&
2756          iprev,9900+irecv,FG_COMM,status,IERR)
2757 !        write (iout,*) "Gather PRECOMP23"
2758 !        call flush(iout)
2759         endif
2760         isend=irecv
2761         irecv=irecv-1
2762         if (irecv.lt.0) irecv=nfgtasks1-1
2763       enddo
2764 #endif
2765         time_gather=time_gather+MPI_Wtime()-time00
2766       endif
2767 #ifdef DEBUG
2768 !      if (fg_rank.eq.0) then
2769         write (iout,*) "Arrays UG and UGDER"
2770         do i=1,nres-1
2771           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2772            ((ug(l,k,i),l=1,2),k=1,2),&
2773            ((ugder(l,k,i),l=1,2),k=1,2)
2774         enddo
2775         write (iout,*) "Arrays UG2 and UG2DER"
2776         do i=1,nres-1
2777           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2778            ((ug2(l,k,i),l=1,2),k=1,2),&
2779            ((ug2der(l,k,i),l=1,2),k=1,2)
2780         enddo
2781         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2782         do i=1,nres-1
2783           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2784            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2785            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2786         enddo
2787         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2788         do i=1,nres-1
2789           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2790            costab(i),sintab(i),costab2(i),sintab2(i)
2791         enddo
2792         write (iout,*) "Array MUDER"
2793         do i=1,nres-1
2794           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2795         enddo
2796 !      endif
2797 #endif
2798 #endif
2799 !d      do i=1,nres
2800 !d        iti = itortyp(itype(i,1))
2801 !d        write (iout,*) i
2802 !d        do j=1,2
2803 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2804 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2805 !d        enddo
2806 !d      enddo
2807       return
2808       end subroutine set_matrices
2809 !-----------------------------------------------------------------------------
2810       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2811 !
2812 ! This subroutine calculates the average interaction energy and its gradient
2813 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2814 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2815 ! The potential depends both on the distance of peptide-group centers and on
2816 ! the orientation of the CA-CA virtual bonds.
2817 !
2818       use comm_locel
2819 !      implicit real*8 (a-h,o-z)
2820 #ifdef MPI
2821       include 'mpif.h'
2822 #endif
2823 !      include 'DIMENSIONS'
2824 !      include 'COMMON.CONTROL'
2825 !      include 'COMMON.SETUP'
2826 !      include 'COMMON.IOUNITS'
2827 !      include 'COMMON.GEO'
2828 !      include 'COMMON.VAR'
2829 !      include 'COMMON.LOCAL'
2830 !      include 'COMMON.CHAIN'
2831 !      include 'COMMON.DERIV'
2832 !      include 'COMMON.INTERACT'
2833 !      include 'COMMON.CONTACTS'
2834 !      include 'COMMON.TORSION'
2835 !      include 'COMMON.VECTORS'
2836 !      include 'COMMON.FFIELD'
2837 !      include 'COMMON.TIME1'
2838       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2839       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2840       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2841 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2842       real(kind=8),dimension(4) :: muij
2843 !el      integer :: num_conti,j1,j2
2844 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2845 !el        dz_normi,xmedi,ymedi,zmedi
2846
2847 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2848 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2849 !el          num_conti,j1,j2
2850
2851 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2852 #ifdef MOMENT
2853       real(kind=8) :: scal_el=1.0d0
2854 #else
2855       real(kind=8) :: scal_el=0.5d0
2856 #endif
2857 ! 12/13/98
2858 ! 13-go grudnia roku pamietnego...
2859       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2860                                              0.0d0,1.0d0,0.0d0,&
2861                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2862 !el local variables
2863       integer :: i,k,j
2864       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2865       real(kind=8) :: fac,t_eelecij,fracinbuf
2866
2867
2868 !d      write(iout,*) 'In EELEC'
2869 !        print *,"IN EELEC"
2870 !d      do i=1,nloctyp
2871 !d        write(iout,*) 'Type',i
2872 !d        write(iout,*) 'B1',B1(:,i)
2873 !d        write(iout,*) 'B2',B2(:,i)
2874 !d        write(iout,*) 'CC',CC(:,:,i)
2875 !d        write(iout,*) 'DD',DD(:,:,i)
2876 !d        write(iout,*) 'EE',EE(:,:,i)
2877 !d      enddo
2878 !d      call check_vecgrad
2879 !d      stop
2880 !      ees=0.0d0  !AS
2881 !      evdw1=0.0d0
2882 !      eel_loc=0.0d0
2883 !      eello_turn3=0.0d0
2884 !      eello_turn4=0.0d0
2885       t_eelecij=0.0d0
2886       ees=0.0D0
2887       evdw1=0.0D0
2888       eel_loc=0.0d0
2889       eello_turn3=0.0d0
2890       eello_turn4=0.0d0
2891 !
2892
2893       if (icheckgrad.eq.1) then
2894 !el
2895 !        do i=0,2*nres+2
2896 !          dc_norm(1,i)=0.0d0
2897 !          dc_norm(2,i)=0.0d0
2898 !          dc_norm(3,i)=0.0d0
2899 !        enddo
2900         do i=1,nres-1
2901           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2902           do k=1,3
2903             dc_norm(k,i)=dc(k,i)*fac
2904           enddo
2905 !          write (iout,*) 'i',i,' fac',fac
2906         enddo
2907       endif
2908 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
2909 !        wturn6
2910       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2911           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2912           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2913 !        call vec_and_deriv
2914 #ifdef TIMING
2915         time01=MPI_Wtime()
2916 #endif
2917 !        print *, "before set matrices"
2918         call set_matrices
2919 !        print *, "after set matrices"
2920
2921 #ifdef TIMING
2922         time_mat=time_mat+MPI_Wtime()-time01
2923 #endif
2924       endif
2925 !       print *, "after set matrices"
2926 !d      do i=1,nres-1
2927 !d        write (iout,*) 'i=',i
2928 !d        do k=1,3
2929 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2930 !d        enddo
2931 !d        do k=1,3
2932 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2933 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2934 !d        enddo
2935 !d      enddo
2936       t_eelecij=0.0d0
2937       ees=0.0D0
2938       evdw1=0.0D0
2939       eel_loc=0.0d0
2940       eello_turn3=0.0d0
2941       eello_turn4=0.0d0
2942 !el      ind=0
2943       do i=1,nres
2944         num_cont_hb(i)=0
2945       enddo
2946 !d      print '(a)','Enter EELEC'
2947 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2948 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2949 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2950       do i=1,nres
2951         gel_loc_loc(i)=0.0d0
2952         gcorr_loc(i)=0.0d0
2953       enddo
2954 !
2955 !
2956 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2957 !
2958 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
2959 !
2960
2961
2962 !        print *,"before iturn3 loop"
2963       do i=iturn3_start,iturn3_end
2964         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
2965         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
2966         dxi=dc(1,i)
2967         dyi=dc(2,i)
2968         dzi=dc(3,i)
2969         dx_normi=dc_norm(1,i)
2970         dy_normi=dc_norm(2,i)
2971         dz_normi=dc_norm(3,i)
2972         xmedi=c(1,i)+0.5d0*dxi
2973         ymedi=c(2,i)+0.5d0*dyi
2974         zmedi=c(3,i)+0.5d0*dzi
2975           xmedi=dmod(xmedi,boxxsize)
2976           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2977           ymedi=dmod(ymedi,boxysize)
2978           if (ymedi.lt.0) ymedi=ymedi+boxysize
2979           zmedi=dmod(zmedi,boxzsize)
2980           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2981         num_conti=0
2982        if ((zmedi.gt.bordlipbot) &
2983         .and.(zmedi.lt.bordliptop)) then
2984 !C the energy transfer exist
2985         if (zmedi.lt.buflipbot) then
2986 !C what fraction I am in
2987          fracinbuf=1.0d0- &
2988                ((zmedi-bordlipbot)/lipbufthick)
2989 !C lipbufthick is thickenes of lipid buffore
2990          sslipi=sscalelip(fracinbuf)
2991          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2992         elseif (zmedi.gt.bufliptop) then
2993          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
2994          sslipi=sscalelip(fracinbuf)
2995          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2996         else
2997          sslipi=1.0d0
2998          ssgradlipi=0.0
2999         endif
3000        else
3001          sslipi=0.0d0
3002          ssgradlipi=0.0
3003        endif
3004 !       print *,i,sslipi,ssgradlipi
3005        call eelecij(i,i+2,ees,evdw1,eel_loc)
3006         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3007         num_cont_hb(i)=num_conti
3008       enddo
3009       do i=iturn4_start,iturn4_end
3010         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3011           .or. itype(i+3,1).eq.ntyp1 &
3012           .or. itype(i+4,1).eq.ntyp1) cycle
3013         dxi=dc(1,i)
3014         dyi=dc(2,i)
3015         dzi=dc(3,i)
3016         dx_normi=dc_norm(1,i)
3017         dy_normi=dc_norm(2,i)
3018         dz_normi=dc_norm(3,i)
3019         xmedi=c(1,i)+0.5d0*dxi
3020         ymedi=c(2,i)+0.5d0*dyi
3021         zmedi=c(3,i)+0.5d0*dzi
3022           xmedi=dmod(xmedi,boxxsize)
3023           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3024           ymedi=dmod(ymedi,boxysize)
3025           if (ymedi.lt.0) ymedi=ymedi+boxysize
3026           zmedi=dmod(zmedi,boxzsize)
3027           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3028        if ((zmedi.gt.bordlipbot)  &
3029        .and.(zmedi.lt.bordliptop)) then
3030 !C the energy transfer exist
3031         if (zmedi.lt.buflipbot) then
3032 !C what fraction I am in
3033          fracinbuf=1.0d0- &
3034              ((zmedi-bordlipbot)/lipbufthick)
3035 !C lipbufthick is thickenes of lipid buffore
3036          sslipi=sscalelip(fracinbuf)
3037          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3038         elseif (zmedi.gt.bufliptop) then
3039          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3040          sslipi=sscalelip(fracinbuf)
3041          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3042         else
3043          sslipi=1.0d0
3044          ssgradlipi=0.0
3045         endif
3046        else
3047          sslipi=0.0d0
3048          ssgradlipi=0.0
3049        endif
3050
3051         num_conti=num_cont_hb(i)
3052         call eelecij(i,i+3,ees,evdw1,eel_loc)
3053         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3054          call eturn4(i,eello_turn4)
3055         num_cont_hb(i)=num_conti
3056       enddo   ! i
3057 !
3058 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3059 !
3060       do i=iatel_s,iatel_e
3061         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3062         dxi=dc(1,i)
3063         dyi=dc(2,i)
3064         dzi=dc(3,i)
3065         dx_normi=dc_norm(1,i)
3066         dy_normi=dc_norm(2,i)
3067         dz_normi=dc_norm(3,i)
3068         xmedi=c(1,i)+0.5d0*dxi
3069         ymedi=c(2,i)+0.5d0*dyi
3070         zmedi=c(3,i)+0.5d0*dzi
3071           xmedi=dmod(xmedi,boxxsize)
3072           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3073           ymedi=dmod(ymedi,boxysize)
3074           if (ymedi.lt.0) ymedi=ymedi+boxysize
3075           zmedi=dmod(zmedi,boxzsize)
3076           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3077        if ((zmedi.gt.bordlipbot)  &
3078         .and.(zmedi.lt.bordliptop)) then
3079 !C the energy transfer exist
3080         if (zmedi.lt.buflipbot) then
3081 !C what fraction I am in
3082          fracinbuf=1.0d0- &
3083              ((zmedi-bordlipbot)/lipbufthick)
3084 !C lipbufthick is thickenes of lipid buffore
3085          sslipi=sscalelip(fracinbuf)
3086          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3087         elseif (zmedi.gt.bufliptop) then
3088          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3089          sslipi=sscalelip(fracinbuf)
3090          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3091         else
3092          sslipi=1.0d0
3093          ssgradlipi=0.0
3094         endif
3095        else
3096          sslipi=0.0d0
3097          ssgradlipi=0.0
3098        endif
3099
3100 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3101         num_conti=num_cont_hb(i)
3102         do j=ielstart(i),ielend(i)
3103 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3104           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3105           call eelecij(i,j,ees,evdw1,eel_loc)
3106         enddo ! j
3107         num_cont_hb(i)=num_conti
3108       enddo   ! i
3109 !      write (iout,*) "Number of loop steps in EELEC:",ind
3110 !d      do i=1,nres
3111 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3112 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3113 !d      enddo
3114 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3115 !cc      eel_loc=eel_loc+eello_turn3
3116 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3117       return
3118       end subroutine eelec
3119 !-----------------------------------------------------------------------------
3120       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3121
3122       use comm_locel
3123 !      implicit real*8 (a-h,o-z)
3124 !      include 'DIMENSIONS'
3125 #ifdef MPI
3126       include "mpif.h"
3127 #endif
3128 !      include 'COMMON.CONTROL'
3129 !      include 'COMMON.IOUNITS'
3130 !      include 'COMMON.GEO'
3131 !      include 'COMMON.VAR'
3132 !      include 'COMMON.LOCAL'
3133 !      include 'COMMON.CHAIN'
3134 !      include 'COMMON.DERIV'
3135 !      include 'COMMON.INTERACT'
3136 !      include 'COMMON.CONTACTS'
3137 !      include 'COMMON.TORSION'
3138 !      include 'COMMON.VECTORS'
3139 !      include 'COMMON.FFIELD'
3140 !      include 'COMMON.TIME1'
3141       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3142       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3143       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3144 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3145       real(kind=8),dimension(4) :: muij
3146       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3147                     dist_temp, dist_init,rlocshield,fracinbuf
3148       integer xshift,yshift,zshift,ilist,iresshield
3149 !el      integer :: num_conti,j1,j2
3150 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3151 !el        dz_normi,xmedi,ymedi,zmedi
3152
3153 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3154 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3155 !el          num_conti,j1,j2
3156
3157 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3158 #ifdef MOMENT
3159       real(kind=8) :: scal_el=1.0d0
3160 #else
3161       real(kind=8) :: scal_el=0.5d0
3162 #endif
3163 ! 12/13/98
3164 ! 13-go grudnia roku pamietnego...
3165       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3166                                              0.0d0,1.0d0,0.0d0,&
3167                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3168 !      integer :: maxconts=nres/4
3169 !el local variables
3170       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3171       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3172       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3173       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3174                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3175                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3176                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3177                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3178                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3179                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3180                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3181 !      maxconts=nres/4
3182 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3183 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3184
3185 !          time00=MPI_Wtime()
3186 !d      write (iout,*) "eelecij",i,j
3187 !          ind=ind+1
3188           iteli=itel(i)
3189           itelj=itel(j)
3190           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3191           aaa=app(iteli,itelj)
3192           bbb=bpp(iteli,itelj)
3193           ael6i=ael6(iteli,itelj)
3194           ael3i=ael3(iteli,itelj)
3195           dxj=dc(1,j)
3196           dyj=dc(2,j)
3197           dzj=dc(3,j)
3198           dx_normj=dc_norm(1,j)
3199           dy_normj=dc_norm(2,j)
3200           dz_normj=dc_norm(3,j)
3201 !          xj=c(1,j)+0.5D0*dxj-xmedi
3202 !          yj=c(2,j)+0.5D0*dyj-ymedi
3203 !          zj=c(3,j)+0.5D0*dzj-zmedi
3204           xj=c(1,j)+0.5D0*dxj
3205           yj=c(2,j)+0.5D0*dyj
3206           zj=c(3,j)+0.5D0*dzj
3207           xj=mod(xj,boxxsize)
3208           if (xj.lt.0) xj=xj+boxxsize
3209           yj=mod(yj,boxysize)
3210           if (yj.lt.0) yj=yj+boxysize
3211           zj=mod(zj,boxzsize)
3212           if (zj.lt.0) zj=zj+boxzsize
3213        if ((zj.gt.bordlipbot)  &
3214        .and.(zj.lt.bordliptop)) then
3215 !C the energy transfer exist
3216         if (zj.lt.buflipbot) then
3217 !C what fraction I am in
3218          fracinbuf=1.0d0-     &
3219              ((zj-bordlipbot)/lipbufthick)
3220 !C lipbufthick is thickenes of lipid buffore
3221          sslipj=sscalelip(fracinbuf)
3222          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3223         elseif (zj.gt.bufliptop) then
3224          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3225          sslipj=sscalelip(fracinbuf)
3226          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3227         else
3228          sslipj=1.0d0
3229          ssgradlipj=0.0
3230         endif
3231        else
3232          sslipj=0.0d0
3233          ssgradlipj=0.0
3234        endif
3235
3236       isubchap=0
3237       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3238       xj_safe=xj
3239       yj_safe=yj
3240       zj_safe=zj
3241       do xshift=-1,1
3242       do yshift=-1,1
3243       do zshift=-1,1
3244           xj=xj_safe+xshift*boxxsize
3245           yj=yj_safe+yshift*boxysize
3246           zj=zj_safe+zshift*boxzsize
3247           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3248           if(dist_temp.lt.dist_init) then
3249             dist_init=dist_temp
3250             xj_temp=xj
3251             yj_temp=yj
3252             zj_temp=zj
3253             isubchap=1
3254           endif
3255        enddo
3256        enddo
3257        enddo
3258        if (isubchap.eq.1) then
3259 !C          print *,i,j
3260           xj=xj_temp-xmedi
3261           yj=yj_temp-ymedi
3262           zj=zj_temp-zmedi
3263        else
3264           xj=xj_safe-xmedi
3265           yj=yj_safe-ymedi
3266           zj=zj_safe-zmedi
3267        endif
3268
3269           rij=xj*xj+yj*yj+zj*zj
3270           rrmij=1.0D0/rij
3271           rij=dsqrt(rij)
3272 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3273             sss_ele_cut=sscale_ele(rij)
3274             sss_ele_grad=sscagrad_ele(rij)
3275 !             sss_ele_cut=1.0d0
3276 !             sss_ele_grad=0.0d0
3277 !            print *,sss_ele_cut,sss_ele_grad,&
3278 !            (rij),r_cut_ele,rlamb_ele
3279 !            if (sss_ele_cut.le.0.0) go to 128
3280
3281           rmij=1.0D0/rij
3282           r3ij=rrmij*rmij
3283           r6ij=r3ij*r3ij
3284           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3285           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3286           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3287           fac=cosa-3.0D0*cosb*cosg
3288           ev1=aaa*r6ij*r6ij
3289 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3290           if (j.eq.i+2) ev1=scal_el*ev1
3291           ev2=bbb*r6ij
3292           fac3=ael6i*r6ij
3293           fac4=ael3i*r3ij
3294           evdwij=ev1+ev2
3295           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3296           el2=fac4*fac
3297 !          eesij=el1+el2
3298           if (shield_mode.gt.0) then
3299 !C          fac_shield(i)=0.4
3300 !C          fac_shield(j)=0.6
3301           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3302           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3303           eesij=(el1+el2)
3304           ees=ees+eesij*sss_ele_cut
3305 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3306 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3307           else
3308           fac_shield(i)=1.0
3309           fac_shield(j)=1.0
3310           eesij=(el1+el2)
3311           ees=ees+eesij   &
3312             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3313 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3314           endif
3315
3316 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3317           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3318 !          ees=ees+eesij*sss_ele_cut
3319           evdw1=evdw1+evdwij*sss_ele_cut  &
3320            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3321 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3322 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3323 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3324 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3325
3326           if (energy_dec) then
3327 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3328 !                  'evdw1',i,j,evdwij,&
3329 !                  iteli,itelj,aaa,evdw1
3330               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3331               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3332           endif
3333 !
3334 ! Calculate contributions to the Cartesian gradient.
3335 !
3336 #ifdef SPLITELE
3337           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3338               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3339           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3340              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3341           fac1=fac
3342           erij(1)=xj*rmij
3343           erij(2)=yj*rmij
3344           erij(3)=zj*rmij
3345 !
3346 ! Radial derivatives. First process both termini of the fragment (i,j)
3347 !
3348           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3349           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3350           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3351            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3352           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3353             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3354
3355           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3356           (shield_mode.gt.0)) then
3357 !C          print *,i,j
3358           do ilist=1,ishield_list(i)
3359            iresshield=shield_list(ilist,i)
3360            do k=1,3
3361            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3362            *2.0*sss_ele_cut
3363            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3364                    rlocshield &
3365             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3366             *sss_ele_cut
3367             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3368            enddo
3369           enddo
3370           do ilist=1,ishield_list(j)
3371            iresshield=shield_list(ilist,j)
3372            do k=1,3
3373            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3374           *2.0*sss_ele_cut
3375            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3376                    rlocshield &
3377            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3378            *sss_ele_cut
3379            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3380            enddo
3381           enddo
3382           do k=1,3
3383             gshieldc(k,i)=gshieldc(k,i)+ &
3384                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3385            *sss_ele_cut
3386
3387             gshieldc(k,j)=gshieldc(k,j)+ &
3388                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3389            *sss_ele_cut
3390
3391             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3392                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3393            *sss_ele_cut
3394
3395             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3396                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3397            *sss_ele_cut
3398
3399            enddo
3400            endif
3401
3402
3403 !          do k=1,3
3404 !            ghalf=0.5D0*ggg(k)
3405 !            gelc(k,i)=gelc(k,i)+ghalf
3406 !            gelc(k,j)=gelc(k,j)+ghalf
3407 !          enddo
3408 ! 9/28/08 AL Gradient compotents will be summed only at the end
3409           do k=1,3
3410             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3411             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3412           enddo
3413             gelc_long(3,j)=gelc_long(3,j)+  &
3414           ssgradlipj*eesij/2.0d0*lipscale**2&
3415            *sss_ele_cut
3416
3417             gelc_long(3,i)=gelc_long(3,i)+  &
3418           ssgradlipi*eesij/2.0d0*lipscale**2&
3419            *sss_ele_cut
3420
3421
3422 !
3423 ! Loop over residues i+1 thru j-1.
3424 !
3425 !grad          do k=i+1,j-1
3426 !grad            do l=1,3
3427 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3428 !grad            enddo
3429 !grad          enddo
3430           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3431            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3432           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3433            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3434           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3435            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3436
3437 !          do k=1,3
3438 !            ghalf=0.5D0*ggg(k)
3439 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3440 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3441 !          enddo
3442 ! 9/28/08 AL Gradient compotents will be summed only at the end
3443           do k=1,3
3444             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3445             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3446           enddo
3447
3448 !C Lipidic part for scaling weight
3449            gvdwpp(3,j)=gvdwpp(3,j)+ &
3450           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3451            gvdwpp(3,i)=gvdwpp(3,i)+ &
3452           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3453 !! Loop over residues i+1 thru j-1.
3454 !
3455 !grad          do k=i+1,j-1
3456 !grad            do l=1,3
3457 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3458 !grad            enddo
3459 !grad          enddo
3460 #else
3461           facvdw=(ev1+evdwij)*sss_ele_cut &
3462            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3463
3464           facel=(el1+eesij)*sss_ele_cut
3465           fac1=fac
3466           fac=-3*rrmij*(facvdw+facvdw+facel)
3467           erij(1)=xj*rmij
3468           erij(2)=yj*rmij
3469           erij(3)=zj*rmij
3470 !
3471 ! Radial derivatives. First process both termini of the fragment (i,j)
3472 !
3473           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3474           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3475           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3476 !          do k=1,3
3477 !            ghalf=0.5D0*ggg(k)
3478 !            gelc(k,i)=gelc(k,i)+ghalf
3479 !            gelc(k,j)=gelc(k,j)+ghalf
3480 !          enddo
3481 ! 9/28/08 AL Gradient compotents will be summed only at the end
3482           do k=1,3
3483             gelc_long(k,j)=gelc(k,j)+ggg(k)
3484             gelc_long(k,i)=gelc(k,i)-ggg(k)
3485           enddo
3486 !
3487 ! Loop over residues i+1 thru j-1.
3488 !
3489 !grad          do k=i+1,j-1
3490 !grad            do l=1,3
3491 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3492 !grad            enddo
3493 !grad          enddo
3494 ! 9/28/08 AL Gradient compotents will be summed only at the end
3495           ggg(1)=facvdw*xj &
3496            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3497           ggg(2)=facvdw*yj &
3498            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3499           ggg(3)=facvdw*zj &
3500            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3501
3502           do k=1,3
3503             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3504             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3505           enddo
3506            gvdwpp(3,j)=gvdwpp(3,j)+ &
3507           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3508            gvdwpp(3,i)=gvdwpp(3,i)+ &
3509           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3510
3511 #endif
3512 !
3513 ! Angular part
3514 !
3515           ecosa=2.0D0*fac3*fac1+fac4
3516           fac4=-3.0D0*fac4
3517           fac3=-6.0D0*fac3
3518           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3519           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3520           do k=1,3
3521             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3522             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3523           enddo
3524 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3525 !d   &          (dcosg(k),k=1,3)
3526           do k=1,3
3527             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3528              *fac_shield(i)**2*fac_shield(j)**2 &
3529              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3530
3531           enddo
3532 !          do k=1,3
3533 !            ghalf=0.5D0*ggg(k)
3534 !            gelc(k,i)=gelc(k,i)+ghalf
3535 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3536 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3537 !            gelc(k,j)=gelc(k,j)+ghalf
3538 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3539 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3540 !          enddo
3541 !grad          do k=i+1,j-1
3542 !grad            do l=1,3
3543 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3544 !grad            enddo
3545 !grad          enddo
3546           do k=1,3
3547             gelc(k,i)=gelc(k,i) &
3548                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3549                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3550                      *sss_ele_cut &
3551                      *fac_shield(i)**2*fac_shield(j)**2 &
3552                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3553
3554             gelc(k,j)=gelc(k,j) &
3555                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3556                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3557                      *sss_ele_cut  &
3558                      *fac_shield(i)**2*fac_shield(j)**2  &
3559                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3560
3561             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3562             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3563           enddo
3564
3565           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3566               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3567               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3568 !
3569 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3570 !   energy of a peptide unit is assumed in the form of a second-order
3571 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3572 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3573 !   are computed for EVERY pair of non-contiguous peptide groups.
3574 !
3575           if (j.lt.nres-1) then
3576             j1=j+1
3577             j2=j-1
3578           else
3579             j1=j-1
3580             j2=j-2
3581           endif
3582           kkk=0
3583           do k=1,2
3584             do l=1,2
3585               kkk=kkk+1
3586               muij(kkk)=mu(k,i)*mu(l,j)
3587             enddo
3588           enddo
3589 !d         write (iout,*) 'EELEC: i',i,' j',j
3590 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3591 !d          write(iout,*) 'muij',muij
3592           ury=scalar(uy(1,i),erij)
3593           urz=scalar(uz(1,i),erij)
3594           vry=scalar(uy(1,j),erij)
3595           vrz=scalar(uz(1,j),erij)
3596           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3597           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3598           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3599           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3600           fac=dsqrt(-ael6i)*r3ij
3601           a22=a22*fac
3602           a23=a23*fac
3603           a32=a32*fac
3604           a33=a33*fac
3605 !d          write (iout,'(4i5,4f10.5)')
3606 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3607 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3608 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3609 !d     &      uy(:,j),uz(:,j)
3610 !d          write (iout,'(4f10.5)')
3611 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3612 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3613 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3614 !d           write (iout,'(9f10.5/)')
3615 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3616 ! Derivatives of the elements of A in virtual-bond vectors
3617           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3618           do k=1,3
3619             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3620             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3621             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3622             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3623             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3624             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3625             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3626             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3627             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3628             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3629             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3630             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3631           enddo
3632 ! Compute radial contributions to the gradient
3633           facr=-3.0d0*rrmij
3634           a22der=a22*facr
3635           a23der=a23*facr
3636           a32der=a32*facr
3637           a33der=a33*facr
3638           agg(1,1)=a22der*xj
3639           agg(2,1)=a22der*yj
3640           agg(3,1)=a22der*zj
3641           agg(1,2)=a23der*xj
3642           agg(2,2)=a23der*yj
3643           agg(3,2)=a23der*zj
3644           agg(1,3)=a32der*xj
3645           agg(2,3)=a32der*yj
3646           agg(3,3)=a32der*zj
3647           agg(1,4)=a33der*xj
3648           agg(2,4)=a33der*yj
3649           agg(3,4)=a33der*zj
3650 ! Add the contributions coming from er
3651           fac3=-3.0d0*fac
3652           do k=1,3
3653             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3654             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3655             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3656             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3657           enddo
3658           do k=1,3
3659 ! Derivatives in DC(i)
3660 !grad            ghalf1=0.5d0*agg(k,1)
3661 !grad            ghalf2=0.5d0*agg(k,2)
3662 !grad            ghalf3=0.5d0*agg(k,3)
3663 !grad            ghalf4=0.5d0*agg(k,4)
3664             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3665             -3.0d0*uryg(k,2)*vry)!+ghalf1
3666             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3667             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3668             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3669             -3.0d0*urzg(k,2)*vry)!+ghalf3
3670             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3671             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3672 ! Derivatives in DC(i+1)
3673             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3674             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3675             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3676             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3677             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3678             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3679             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3680             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3681 ! Derivatives in DC(j)
3682             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3683             -3.0d0*vryg(k,2)*ury)!+ghalf1
3684             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3685             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3686             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3687             -3.0d0*vryg(k,2)*urz)!+ghalf3
3688             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3689             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3690 ! Derivatives in DC(j+1) or DC(nres-1)
3691             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3692             -3.0d0*vryg(k,3)*ury)
3693             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3694             -3.0d0*vrzg(k,3)*ury)
3695             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3696             -3.0d0*vryg(k,3)*urz)
3697             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3698             -3.0d0*vrzg(k,3)*urz)
3699 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3700 !grad              do l=1,4
3701 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3702 !grad              enddo
3703 !grad            endif
3704           enddo
3705           acipa(1,1)=a22
3706           acipa(1,2)=a23
3707           acipa(2,1)=a32
3708           acipa(2,2)=a33
3709           a22=-a22
3710           a23=-a23
3711           do l=1,2
3712             do k=1,3
3713               agg(k,l)=-agg(k,l)
3714               aggi(k,l)=-aggi(k,l)
3715               aggi1(k,l)=-aggi1(k,l)
3716               aggj(k,l)=-aggj(k,l)
3717               aggj1(k,l)=-aggj1(k,l)
3718             enddo
3719           enddo
3720           if (j.lt.nres-1) then
3721             a22=-a22
3722             a32=-a32
3723             do l=1,3,2
3724               do k=1,3
3725                 agg(k,l)=-agg(k,l)
3726                 aggi(k,l)=-aggi(k,l)
3727                 aggi1(k,l)=-aggi1(k,l)
3728                 aggj(k,l)=-aggj(k,l)
3729                 aggj1(k,l)=-aggj1(k,l)
3730               enddo
3731             enddo
3732           else
3733             a22=-a22
3734             a23=-a23
3735             a32=-a32
3736             a33=-a33
3737             do l=1,4
3738               do k=1,3
3739                 agg(k,l)=-agg(k,l)
3740                 aggi(k,l)=-aggi(k,l)
3741                 aggi1(k,l)=-aggi1(k,l)
3742                 aggj(k,l)=-aggj(k,l)
3743                 aggj1(k,l)=-aggj1(k,l)
3744               enddo
3745             enddo
3746           endif
3747           ENDIF ! WCORR
3748           IF (wel_loc.gt.0.0d0) THEN
3749 ! Contribution to the local-electrostatic energy coming from the i-j pair
3750           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3751            +a33*muij(4)
3752           if (shield_mode.eq.0) then
3753            fac_shield(i)=1.0
3754            fac_shield(j)=1.0
3755           endif
3756           eel_loc_ij=eel_loc_ij &
3757          *fac_shield(i)*fac_shield(j) &
3758          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3759 !C Now derivative over eel_loc
3760           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3761          (shield_mode.gt.0)) then
3762 !C          print *,i,j
3763
3764           do ilist=1,ishield_list(i)
3765            iresshield=shield_list(ilist,i)
3766            do k=1,3
3767            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3768                                                 /fac_shield(i)&
3769            *sss_ele_cut
3770            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3771                    rlocshield  &
3772           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3773           *sss_ele_cut
3774
3775             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3776            +rlocshield
3777            enddo
3778           enddo
3779           do ilist=1,ishield_list(j)
3780            iresshield=shield_list(ilist,j)
3781            do k=1,3
3782            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3783                                             /fac_shield(j)   &
3784             *sss_ele_cut
3785            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3786                    rlocshield  &
3787       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3788        *sss_ele_cut
3789
3790            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3791                   +rlocshield
3792
3793            enddo
3794           enddo
3795
3796           do k=1,3
3797             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3798                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3799                     *sss_ele_cut
3800             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3801                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3802                     *sss_ele_cut
3803             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3804                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3805                     *sss_ele_cut
3806             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3807                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3808                     *sss_ele_cut
3809
3810            enddo
3811            endif
3812
3813
3814 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3815 !           eel_loc_ij=0.0
3816           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3817                   'eelloc',i,j,eel_loc_ij
3818 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3819 !          if (energy_dec) write (iout,*) "muij",muij
3820 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3821
3822           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3823 ! Partial derivatives in virtual-bond dihedral angles gamma
3824           if (i.gt.1) &
3825           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3826                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3827                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3828                  *sss_ele_cut  &
3829           *fac_shield(i)*fac_shield(j) &
3830           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3831
3832           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3833                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3834                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3835                  *sss_ele_cut &
3836           *fac_shield(i)*fac_shield(j) &
3837           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3838 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3839 !          do l=1,3
3840 !            ggg(1)=(agg(1,1)*muij(1)+ &
3841 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3842 !            *sss_ele_cut &
3843 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3844 !            ggg(2)=(agg(2,1)*muij(1)+ &
3845 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3846 !            *sss_ele_cut &
3847 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3848 !            ggg(3)=(agg(3,1)*muij(1)+ &
3849 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3850 !            *sss_ele_cut &
3851 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3852            xtemp(1)=xj
3853            xtemp(2)=yj
3854            xtemp(3)=zj
3855
3856            do l=1,3
3857             ggg(l)=(agg(l,1)*muij(1)+ &
3858                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3859             *sss_ele_cut &
3860           *fac_shield(i)*fac_shield(j) &
3861           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
3862              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3863
3864
3865             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3866             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3867 !grad            ghalf=0.5d0*ggg(l)
3868 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3869 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3870           enddo
3871             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
3872           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
3873           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3874
3875             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
3876           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
3877           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3878
3879 !grad          do k=i+1,j2
3880 !grad            do l=1,3
3881 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3882 !grad            enddo
3883 !grad          enddo
3884 ! Remaining derivatives of eello
3885           do l=1,3
3886             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
3887                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
3888             *sss_ele_cut &
3889           *fac_shield(i)*fac_shield(j) &
3890           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3891
3892 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3893             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
3894                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
3895             +aggi1(l,4)*muij(4))&
3896             *sss_ele_cut &
3897           *fac_shield(i)*fac_shield(j) &
3898           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3899
3900 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3901             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
3902                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
3903             *sss_ele_cut &
3904           *fac_shield(i)*fac_shield(j) &
3905           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3906
3907 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3908             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
3909                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
3910             +aggj1(l,4)*muij(4))&
3911             *sss_ele_cut &
3912           *fac_shield(i)*fac_shield(j) &
3913           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3914
3915 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3916           enddo
3917           ENDIF
3918 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3919 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3920           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3921              .and. num_conti.le.maxconts) then
3922 !            write (iout,*) i,j," entered corr"
3923 !
3924 ! Calculate the contact function. The ith column of the array JCONT will
3925 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3926 ! greater than I). The arrays FACONT and GACONT will contain the values of
3927 ! the contact function and its derivative.
3928 !           r0ij=1.02D0*rpp(iteli,itelj)
3929 !           r0ij=1.11D0*rpp(iteli,itelj)
3930             r0ij=2.20D0*rpp(iteli,itelj)
3931 !           r0ij=1.55D0*rpp(iteli,itelj)
3932             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3933 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3934             if (fcont.gt.0.0D0) then
3935               num_conti=num_conti+1
3936               if (num_conti.gt.maxconts) then
3937 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3938 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3939                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3940                                ' will skip next contacts for this conf.', num_conti
3941               else
3942                 jcont_hb(num_conti,i)=j
3943 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3944 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3945                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3946                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3947 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3948 !  terms.
3949                 d_cont(num_conti,i)=rij
3950 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3951 !     --- Electrostatic-interaction matrix ---
3952                 a_chuj(1,1,num_conti,i)=a22
3953                 a_chuj(1,2,num_conti,i)=a23
3954                 a_chuj(2,1,num_conti,i)=a32
3955                 a_chuj(2,2,num_conti,i)=a33
3956 !     --- Gradient of rij
3957                 do kkk=1,3
3958                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3959                 enddo
3960                 kkll=0
3961                 do k=1,2
3962                   do l=1,2
3963                     kkll=kkll+1
3964                     do m=1,3
3965                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3966                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3967                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3968                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3969                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3970                     enddo
3971                   enddo
3972                 enddo
3973                 ENDIF
3974                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3975 ! Calculate contact energies
3976                 cosa4=4.0D0*cosa
3977                 wij=cosa-3.0D0*cosb*cosg
3978                 cosbg1=cosb+cosg
3979                 cosbg2=cosb-cosg
3980 !               fac3=dsqrt(-ael6i)/r0ij**3
3981                 fac3=dsqrt(-ael6i)*r3ij
3982 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3983                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3984                 if (ees0tmp.gt.0) then
3985                   ees0pij=dsqrt(ees0tmp)
3986                 else
3987                   ees0pij=0
3988                 endif
3989                 if (shield_mode.eq.0) then
3990                 fac_shield(i)=1.0d0
3991                 fac_shield(j)=1.0d0
3992                 else
3993                 ees0plist(num_conti,i)=j
3994                 endif
3995 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3996                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3997                 if (ees0tmp.gt.0) then
3998                   ees0mij=dsqrt(ees0tmp)
3999                 else
4000                   ees0mij=0
4001                 endif
4002 !               ees0mij=0.0D0
4003                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4004                      *sss_ele_cut &
4005                      *fac_shield(i)*fac_shield(j)
4006
4007                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4008                      *sss_ele_cut &
4009                      *fac_shield(i)*fac_shield(j)
4010
4011 ! Diagnostics. Comment out or remove after debugging!
4012 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4013 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4014 !               ees0m(num_conti,i)=0.0D0
4015 ! End diagnostics.
4016 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4017 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4018 ! Angular derivatives of the contact function
4019                 ees0pij1=fac3/ees0pij
4020                 ees0mij1=fac3/ees0mij
4021                 fac3p=-3.0D0*fac3*rrmij
4022                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4023                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4024 !               ees0mij1=0.0D0
4025                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4026                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4027                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4028                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4029                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4030                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4031                 ecosap=ecosa1+ecosa2
4032                 ecosbp=ecosb1+ecosb2
4033                 ecosgp=ecosg1+ecosg2
4034                 ecosam=ecosa1-ecosa2
4035                 ecosbm=ecosb1-ecosb2
4036                 ecosgm=ecosg1-ecosg2
4037 ! Diagnostics
4038 !               ecosap=ecosa1
4039 !               ecosbp=ecosb1
4040 !               ecosgp=ecosg1
4041 !               ecosam=0.0D0
4042 !               ecosbm=0.0D0
4043 !               ecosgm=0.0D0
4044 ! End diagnostics
4045                 facont_hb(num_conti,i)=fcont
4046                 fprimcont=fprimcont/rij
4047 !d              facont_hb(num_conti,i)=1.0D0
4048 ! Following line is for diagnostics.
4049 !d              fprimcont=0.0D0
4050                 do k=1,3
4051                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4052                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4053                 enddo
4054                 do k=1,3
4055                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4056                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4057                 enddo
4058                 gggp(1)=gggp(1)+ees0pijp*xj &
4059                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4060                 gggp(2)=gggp(2)+ees0pijp*yj &
4061                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4062                 gggp(3)=gggp(3)+ees0pijp*zj &
4063                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4064
4065                 gggm(1)=gggm(1)+ees0mijp*xj &
4066                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4067
4068                 gggm(2)=gggm(2)+ees0mijp*yj &
4069                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4070
4071                 gggm(3)=gggm(3)+ees0mijp*zj &
4072                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4073
4074 ! Derivatives due to the contact function
4075                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4076                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4077                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4078                 do k=1,3
4079 !
4080 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4081 !          following the change of gradient-summation algorithm.
4082 !
4083 !grad                  ghalfp=0.5D0*gggp(k)
4084 !grad                  ghalfm=0.5D0*gggm(k)
4085                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4086                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4087                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4088                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4089
4090                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4091                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4092                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4093                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4094
4095                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4096                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4097
4098                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4099                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4100                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4101                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4102
4103                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4104                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4105                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4106                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4107
4108                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4109                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4110
4111                 enddo
4112 ! Diagnostics. Comment out or remove after debugging!
4113 !diag           do k=1,3
4114 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4115 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4116 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4117 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4118 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4119 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4120 !diag           enddo
4121               ENDIF ! wcorr
4122               endif  ! num_conti.le.maxconts
4123             endif  ! fcont.gt.0
4124           endif    ! j.gt.i+1
4125           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4126             do k=1,4
4127               do l=1,3
4128                 ghalf=0.5d0*agg(l,k)
4129                 aggi(l,k)=aggi(l,k)+ghalf
4130                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4131                 aggj(l,k)=aggj(l,k)+ghalf
4132               enddo
4133             enddo
4134             if (j.eq.nres-1 .and. i.lt.j-2) then
4135               do k=1,4
4136                 do l=1,3
4137                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4138                 enddo
4139               enddo
4140             endif
4141           endif
4142  128  continue
4143 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4144       return
4145       end subroutine eelecij
4146 !-----------------------------------------------------------------------------
4147       subroutine eturn3(i,eello_turn3)
4148 ! Third- and fourth-order contributions from turns
4149
4150       use comm_locel
4151 !      implicit real*8 (a-h,o-z)
4152 !      include 'DIMENSIONS'
4153 !      include 'COMMON.IOUNITS'
4154 !      include 'COMMON.GEO'
4155 !      include 'COMMON.VAR'
4156 !      include 'COMMON.LOCAL'
4157 !      include 'COMMON.CHAIN'
4158 !      include 'COMMON.DERIV'
4159 !      include 'COMMON.INTERACT'
4160 !      include 'COMMON.CONTACTS'
4161 !      include 'COMMON.TORSION'
4162 !      include 'COMMON.VECTORS'
4163 !      include 'COMMON.FFIELD'
4164 !      include 'COMMON.CONTROL'
4165       real(kind=8),dimension(3) :: ggg
4166       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4167         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4168       real(kind=8),dimension(2) :: auxvec,auxvec1
4169 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4170       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4171 !el      integer :: num_conti,j1,j2
4172 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4173 !el        dz_normi,xmedi,ymedi,zmedi
4174
4175 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4176 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4177 !el         num_conti,j1,j2
4178 !el local variables
4179       integer :: i,j,l,k,ilist,iresshield
4180       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4181
4182       j=i+2
4183 !      write (iout,*) "eturn3",i,j,j1,j2
4184           zj=(c(3,j)+c(3,j+1))/2.0d0
4185           zj=mod(zj,boxzsize)
4186           if (zj.lt.0) zj=zj+boxzsize
4187           if ((zj.lt.0)) write (*,*) "CHUJ"
4188        if ((zj.gt.bordlipbot)  &
4189         .and.(zj.lt.bordliptop)) then
4190 !C the energy transfer exist
4191         if (zj.lt.buflipbot) then
4192 !C what fraction I am in
4193          fracinbuf=1.0d0-     &
4194              ((zj-bordlipbot)/lipbufthick)
4195 !C lipbufthick is thickenes of lipid buffore
4196          sslipj=sscalelip(fracinbuf)
4197          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4198         elseif (zj.gt.bufliptop) then
4199          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4200          sslipj=sscalelip(fracinbuf)
4201          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4202         else
4203          sslipj=1.0d0
4204          ssgradlipj=0.0
4205         endif
4206        else
4207          sslipj=0.0d0
4208          ssgradlipj=0.0
4209        endif
4210
4211       a_temp(1,1)=a22
4212       a_temp(1,2)=a23
4213       a_temp(2,1)=a32
4214       a_temp(2,2)=a33
4215 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4216 !
4217 !               Third-order contributions
4218 !
4219 !                 (i+2)o----(i+3)
4220 !                      | |
4221 !                      | |
4222 !                 (i+1)o----i
4223 !
4224 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4225 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4226         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4227         call transpose2(auxmat(1,1),auxmat1(1,1))
4228         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4229         if (shield_mode.eq.0) then
4230         fac_shield(i)=1.0d0
4231         fac_shield(j)=1.0d0
4232         endif
4233
4234         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4235          *fac_shield(i)*fac_shield(j)  &
4236          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4237         eello_t3= &
4238         0.5d0*(pizda(1,1)+pizda(2,2)) &
4239         *fac_shield(i)*fac_shield(j)
4240
4241         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4242                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4243           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4244        (shield_mode.gt.0)) then
4245 !C          print *,i,j
4246
4247           do ilist=1,ishield_list(i)
4248            iresshield=shield_list(ilist,i)
4249            do k=1,3
4250            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4251            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4252                    rlocshield &
4253            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4254             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4255              +rlocshield
4256            enddo
4257           enddo
4258           do ilist=1,ishield_list(j)
4259            iresshield=shield_list(ilist,j)
4260            do k=1,3
4261            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4262            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4263                    rlocshield &
4264            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4265            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4266                   +rlocshield
4267
4268            enddo
4269           enddo
4270
4271           do k=1,3
4272             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4273                    grad_shield(k,i)*eello_t3/fac_shield(i)
4274             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4275                    grad_shield(k,j)*eello_t3/fac_shield(j)
4276             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4277                    grad_shield(k,i)*eello_t3/fac_shield(i)
4278             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4279                    grad_shield(k,j)*eello_t3/fac_shield(j)
4280            enddo
4281            endif
4282
4283 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4284 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4285 !d     &    ' eello_turn3_num',4*eello_turn3_num
4286 ! Derivatives in gamma(i)
4287         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4288         call transpose2(auxmat2(1,1),auxmat3(1,1))
4289         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4290         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4291           *fac_shield(i)*fac_shield(j)        &
4292           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4293 ! Derivatives in gamma(i+1)
4294         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4295         call transpose2(auxmat2(1,1),auxmat3(1,1))
4296         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4297         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4298           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4299           *fac_shield(i)*fac_shield(j)        &
4300           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4301
4302 ! Cartesian derivatives
4303         do l=1,3
4304 !            ghalf1=0.5d0*agg(l,1)
4305 !            ghalf2=0.5d0*agg(l,2)
4306 !            ghalf3=0.5d0*agg(l,3)
4307 !            ghalf4=0.5d0*agg(l,4)
4308           a_temp(1,1)=aggi(l,1)!+ghalf1
4309           a_temp(1,2)=aggi(l,2)!+ghalf2
4310           a_temp(2,1)=aggi(l,3)!+ghalf3
4311           a_temp(2,2)=aggi(l,4)!+ghalf4
4312           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4313           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4314             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4315           *fac_shield(i)*fac_shield(j)      &
4316           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4317
4318           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4319           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4320           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4321           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4322           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4323           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4324             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4325           *fac_shield(i)*fac_shield(j)        &
4326           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4327
4328           a_temp(1,1)=aggj(l,1)!+ghalf1
4329           a_temp(1,2)=aggj(l,2)!+ghalf2
4330           a_temp(2,1)=aggj(l,3)!+ghalf3
4331           a_temp(2,2)=aggj(l,4)!+ghalf4
4332           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4333           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4334             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4335           *fac_shield(i)*fac_shield(j)      &
4336           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4337
4338           a_temp(1,1)=aggj1(l,1)
4339           a_temp(1,2)=aggj1(l,2)
4340           a_temp(2,1)=aggj1(l,3)
4341           a_temp(2,2)=aggj1(l,4)
4342           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4343           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4344             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4345           *fac_shield(i)*fac_shield(j)        &
4346           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4347         enddo
4348          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4349           ssgradlipi*eello_t3/4.0d0*lipscale
4350          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4351           ssgradlipj*eello_t3/4.0d0*lipscale
4352          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4353           ssgradlipi*eello_t3/4.0d0*lipscale
4354          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4355           ssgradlipj*eello_t3/4.0d0*lipscale
4356
4357       return
4358       end subroutine eturn3
4359 !-----------------------------------------------------------------------------
4360       subroutine eturn4(i,eello_turn4)
4361 ! Third- and fourth-order contributions from turns
4362
4363       use comm_locel
4364 !      implicit real*8 (a-h,o-z)
4365 !      include 'DIMENSIONS'
4366 !      include 'COMMON.IOUNITS'
4367 !      include 'COMMON.GEO'
4368 !      include 'COMMON.VAR'
4369 !      include 'COMMON.LOCAL'
4370 !      include 'COMMON.CHAIN'
4371 !      include 'COMMON.DERIV'
4372 !      include 'COMMON.INTERACT'
4373 !      include 'COMMON.CONTACTS'
4374 !      include 'COMMON.TORSION'
4375 !      include 'COMMON.VECTORS'
4376 !      include 'COMMON.FFIELD'
4377 !      include 'COMMON.CONTROL'
4378       real(kind=8),dimension(3) :: ggg
4379       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4380         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4381       real(kind=8),dimension(2) :: auxvec,auxvec1
4382 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4383       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4384 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4385 !el        dz_normi,xmedi,ymedi,zmedi
4386 !el      integer :: num_conti,j1,j2
4387 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4388 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4389 !el          num_conti,j1,j2
4390 !el local variables
4391       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4392       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4393          rlocshield
4394
4395       j=i+3
4396 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4397 !
4398 !               Fourth-order contributions
4399 !
4400 !                 (i+3)o----(i+4)
4401 !                     /  |
4402 !               (i+2)o   |
4403 !                     \  |
4404 !                 (i+1)o----i
4405 !
4406 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4407 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4408 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4409           zj=(c(3,j)+c(3,j+1))/2.0d0
4410           zj=mod(zj,boxzsize)
4411           if (zj.lt.0) zj=zj+boxzsize
4412        if ((zj.gt.bordlipbot)  &
4413         .and.(zj.lt.bordliptop)) then
4414 !C the energy transfer exist
4415         if (zj.lt.buflipbot) then
4416 !C what fraction I am in
4417          fracinbuf=1.0d0-     &
4418              ((zj-bordlipbot)/lipbufthick)
4419 !C lipbufthick is thickenes of lipid buffore
4420          sslipj=sscalelip(fracinbuf)
4421          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4422         elseif (zj.gt.bufliptop) then
4423          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4424          sslipj=sscalelip(fracinbuf)
4425          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4426         else
4427          sslipj=1.0d0
4428          ssgradlipj=0.0
4429         endif
4430        else
4431          sslipj=0.0d0
4432          ssgradlipj=0.0
4433        endif
4434
4435         a_temp(1,1)=a22
4436         a_temp(1,2)=a23
4437         a_temp(2,1)=a32
4438         a_temp(2,2)=a33
4439         iti1=itortyp(itype(i+1,1))
4440         iti2=itortyp(itype(i+2,1))
4441         iti3=itortyp(itype(i+3,1))
4442 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4443         call transpose2(EUg(1,1,i+1),e1t(1,1))
4444         call transpose2(Eug(1,1,i+2),e2t(1,1))
4445         call transpose2(Eug(1,1,i+3),e3t(1,1))
4446         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4447         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4448         s1=scalar2(b1(1,iti2),auxvec(1))
4449         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4450         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4451         s2=scalar2(b1(1,iti1),auxvec(1))
4452         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4453         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4454         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4455         if (shield_mode.eq.0) then
4456         fac_shield(i)=1.0
4457         fac_shield(j)=1.0
4458         endif
4459
4460         eello_turn4=eello_turn4-(s1+s2+s3) &
4461         *fac_shield(i)*fac_shield(j)       &
4462         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4463         eello_t4=-(s1+s2+s3)  &
4464           *fac_shield(i)*fac_shield(j)
4465 !C Now derivative over shield:
4466           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4467          (shield_mode.gt.0)) then
4468 !C          print *,i,j
4469
4470           do ilist=1,ishield_list(i)
4471            iresshield=shield_list(ilist,i)
4472            do k=1,3
4473            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4474            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4475                    rlocshield &
4476             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4477             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4478            +rlocshield
4479            enddo
4480           enddo
4481           do ilist=1,ishield_list(j)
4482            iresshield=shield_list(ilist,j)
4483            do k=1,3
4484            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4485            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4486                    rlocshield  &
4487            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4488            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4489                   +rlocshield
4490
4491            enddo
4492           enddo
4493
4494           do k=1,3
4495             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4496                    grad_shield(k,i)*eello_t4/fac_shield(i)
4497             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4498                    grad_shield(k,j)*eello_t4/fac_shield(j)
4499             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4500                    grad_shield(k,i)*eello_t4/fac_shield(i)
4501             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4502                    grad_shield(k,j)*eello_t4/fac_shield(j)
4503            enddo
4504            endif
4505
4506         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4507            'eturn4',i,j,-(s1+s2+s3)
4508 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4509 !d     &    ' eello_turn4_num',8*eello_turn4_num
4510 ! Derivatives in gamma(i)
4511         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4512         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4513         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4514         s1=scalar2(b1(1,iti2),auxvec(1))
4515         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4516         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4517         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4518        *fac_shield(i)*fac_shield(j)  &
4519        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4520
4521 ! Derivatives in gamma(i+1)
4522         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4523         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4524         s2=scalar2(b1(1,iti1),auxvec(1))
4525         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4526         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4527         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4528         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4529        *fac_shield(i)*fac_shield(j)  &
4530        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4531
4532 ! Derivatives in gamma(i+2)
4533         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4534         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4535         s1=scalar2(b1(1,iti2),auxvec(1))
4536         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4537         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4538         s2=scalar2(b1(1,iti1),auxvec(1))
4539         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4540         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4541         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4542         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4543        *fac_shield(i)*fac_shield(j)  &
4544        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4545
4546 ! Cartesian derivatives
4547 ! Derivatives of this turn contributions in DC(i+2)
4548         if (j.lt.nres-1) then
4549           do l=1,3
4550             a_temp(1,1)=agg(l,1)
4551             a_temp(1,2)=agg(l,2)
4552             a_temp(2,1)=agg(l,3)
4553             a_temp(2,2)=agg(l,4)
4554             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4555             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4556             s1=scalar2(b1(1,iti2),auxvec(1))
4557             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4558             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4559             s2=scalar2(b1(1,iti1),auxvec(1))
4560             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4561             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4562             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4563             ggg(l)=-(s1+s2+s3)
4564             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4565        *fac_shield(i)*fac_shield(j)  &
4566        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4567
4568           enddo
4569         endif
4570 ! Remaining derivatives of this turn contribution
4571         do l=1,3
4572           a_temp(1,1)=aggi(l,1)
4573           a_temp(1,2)=aggi(l,2)
4574           a_temp(2,1)=aggi(l,3)
4575           a_temp(2,2)=aggi(l,4)
4576           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4577           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4578           s1=scalar2(b1(1,iti2),auxvec(1))
4579           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4580           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4581           s2=scalar2(b1(1,iti1),auxvec(1))
4582           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4583           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4584           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4585           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4586          *fac_shield(i)*fac_shield(j)  &
4587          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4588
4589
4590           a_temp(1,1)=aggi1(l,1)
4591           a_temp(1,2)=aggi1(l,2)
4592           a_temp(2,1)=aggi1(l,3)
4593           a_temp(2,2)=aggi1(l,4)
4594           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4595           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4596           s1=scalar2(b1(1,iti2),auxvec(1))
4597           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4598           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4599           s2=scalar2(b1(1,iti1),auxvec(1))
4600           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4601           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4602           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4603           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4604          *fac_shield(i)*fac_shield(j)  &
4605          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4606
4607
4608           a_temp(1,1)=aggj(l,1)
4609           a_temp(1,2)=aggj(l,2)
4610           a_temp(2,1)=aggj(l,3)
4611           a_temp(2,2)=aggj(l,4)
4612           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4613           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4614           s1=scalar2(b1(1,iti2),auxvec(1))
4615           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4616           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4617           s2=scalar2(b1(1,iti1),auxvec(1))
4618           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4619           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4620           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4621           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4622          *fac_shield(i)*fac_shield(j)  &
4623          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4624
4625
4626           a_temp(1,1)=aggj1(l,1)
4627           a_temp(1,2)=aggj1(l,2)
4628           a_temp(2,1)=aggj1(l,3)
4629           a_temp(2,2)=aggj1(l,4)
4630           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4631           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4632           s1=scalar2(b1(1,iti2),auxvec(1))
4633           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4634           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4635           s2=scalar2(b1(1,iti1),auxvec(1))
4636           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4637           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4638           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4639 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4640           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4641          *fac_shield(i)*fac_shield(j)  &
4642          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4643
4644         enddo
4645          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4646           ssgradlipi*eello_t4/4.0d0*lipscale
4647          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4648           ssgradlipj*eello_t4/4.0d0*lipscale
4649          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4650           ssgradlipi*eello_t4/4.0d0*lipscale
4651          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4652           ssgradlipj*eello_t4/4.0d0*lipscale
4653
4654       return
4655       end subroutine eturn4
4656 !-----------------------------------------------------------------------------
4657       subroutine unormderiv(u,ugrad,unorm,ungrad)
4658 ! This subroutine computes the derivatives of a normalized vector u, given
4659 ! the derivatives computed without normalization conditions, ugrad. Returns
4660 ! ungrad.
4661 !      implicit none
4662       real(kind=8),dimension(3) :: u,vec
4663       real(kind=8),dimension(3,3) ::ugrad,ungrad
4664       real(kind=8) :: unorm     !,scalar
4665       integer :: i,j
4666 !      write (2,*) 'ugrad',ugrad
4667 !      write (2,*) 'u',u
4668       do i=1,3
4669         vec(i)=scalar(ugrad(1,i),u(1))
4670       enddo
4671 !      write (2,*) 'vec',vec
4672       do i=1,3
4673         do j=1,3
4674           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4675         enddo
4676       enddo
4677 !      write (2,*) 'ungrad',ungrad
4678       return
4679       end subroutine unormderiv
4680 !-----------------------------------------------------------------------------
4681       subroutine escp_soft_sphere(evdw2,evdw2_14)
4682 !
4683 ! This subroutine calculates the excluded-volume interaction energy between
4684 ! peptide-group centers and side chains and its gradient in virtual-bond and
4685 ! side-chain vectors.
4686 !
4687 !      implicit real*8 (a-h,o-z)
4688 !      include 'DIMENSIONS'
4689 !      include 'COMMON.GEO'
4690 !      include 'COMMON.VAR'
4691 !      include 'COMMON.LOCAL'
4692 !      include 'COMMON.CHAIN'
4693 !      include 'COMMON.DERIV'
4694 !      include 'COMMON.INTERACT'
4695 !      include 'COMMON.FFIELD'
4696 !      include 'COMMON.IOUNITS'
4697 !      include 'COMMON.CONTROL'
4698       real(kind=8),dimension(3) :: ggg
4699 !el local variables
4700       integer :: i,iint,j,k,iteli,itypj
4701       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4702                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4703
4704       evdw2=0.0D0
4705       evdw2_14=0.0d0
4706       r0_scp=4.5d0
4707 !d    print '(a)','Enter ESCP'
4708 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4709       do i=iatscp_s,iatscp_e
4710         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4711         iteli=itel(i)
4712         xi=0.5D0*(c(1,i)+c(1,i+1))
4713         yi=0.5D0*(c(2,i)+c(2,i+1))
4714         zi=0.5D0*(c(3,i)+c(3,i+1))
4715
4716         do iint=1,nscp_gr(i)
4717
4718         do j=iscpstart(i,iint),iscpend(i,iint)
4719           if (itype(j,1).eq.ntyp1) cycle
4720           itypj=iabs(itype(j,1))
4721 ! Uncomment following three lines for SC-p interactions
4722 !         xj=c(1,nres+j)-xi
4723 !         yj=c(2,nres+j)-yi
4724 !         zj=c(3,nres+j)-zi
4725 ! Uncomment following three lines for Ca-p interactions
4726           xj=c(1,j)-xi
4727           yj=c(2,j)-yi
4728           zj=c(3,j)-zi
4729           rij=xj*xj+yj*yj+zj*zj
4730           r0ij=r0_scp
4731           r0ijsq=r0ij*r0ij
4732           if (rij.lt.r0ijsq) then
4733             evdwij=0.25d0*(rij-r0ijsq)**2
4734             fac=rij-r0ijsq
4735           else
4736             evdwij=0.0d0
4737             fac=0.0d0
4738           endif
4739           evdw2=evdw2+evdwij
4740 !
4741 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4742 !
4743           ggg(1)=xj*fac
4744           ggg(2)=yj*fac
4745           ggg(3)=zj*fac
4746 !grad          if (j.lt.i) then
4747 !d          write (iout,*) 'j<i'
4748 ! Uncomment following three lines for SC-p interactions
4749 !           do k=1,3
4750 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4751 !           enddo
4752 !grad          else
4753 !d          write (iout,*) 'j>i'
4754 !grad            do k=1,3
4755 !grad              ggg(k)=-ggg(k)
4756 ! Uncomment following line for SC-p interactions
4757 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4758 !grad            enddo
4759 !grad          endif
4760 !grad          do k=1,3
4761 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4762 !grad          enddo
4763 !grad          kstart=min0(i+1,j)
4764 !grad          kend=max0(i-1,j-1)
4765 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4766 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4767 !grad          do k=kstart,kend
4768 !grad            do l=1,3
4769 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4770 !grad            enddo
4771 !grad          enddo
4772           do k=1,3
4773             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4774             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4775           enddo
4776         enddo
4777
4778         enddo ! iint
4779       enddo ! i
4780       return
4781       end subroutine escp_soft_sphere
4782 !-----------------------------------------------------------------------------
4783       subroutine escp(evdw2,evdw2_14)
4784 !
4785 ! This subroutine calculates the excluded-volume interaction energy between
4786 ! peptide-group centers and side chains and its gradient in virtual-bond and
4787 ! side-chain vectors.
4788 !
4789 !      implicit real*8 (a-h,o-z)
4790 !      include 'DIMENSIONS'
4791 !      include 'COMMON.GEO'
4792 !      include 'COMMON.VAR'
4793 !      include 'COMMON.LOCAL'
4794 !      include 'COMMON.CHAIN'
4795 !      include 'COMMON.DERIV'
4796 !      include 'COMMON.INTERACT'
4797 !      include 'COMMON.FFIELD'
4798 !      include 'COMMON.IOUNITS'
4799 !      include 'COMMON.CONTROL'
4800       real(kind=8),dimension(3) :: ggg
4801 !el local variables
4802       integer :: i,iint,j,k,iteli,itypj,subchap
4803       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4804                    e1,e2,evdwij,rij
4805       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4806                     dist_temp, dist_init
4807       integer xshift,yshift,zshift
4808
4809       evdw2=0.0D0
4810       evdw2_14=0.0d0
4811 !d    print '(a)','Enter ESCP'
4812 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4813       do i=iatscp_s,iatscp_e
4814         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4815         iteli=itel(i)
4816         xi=0.5D0*(c(1,i)+c(1,i+1))
4817         yi=0.5D0*(c(2,i)+c(2,i+1))
4818         zi=0.5D0*(c(3,i)+c(3,i+1))
4819           xi=mod(xi,boxxsize)
4820           if (xi.lt.0) xi=xi+boxxsize
4821           yi=mod(yi,boxysize)
4822           if (yi.lt.0) yi=yi+boxysize
4823           zi=mod(zi,boxzsize)
4824           if (zi.lt.0) zi=zi+boxzsize
4825
4826         do iint=1,nscp_gr(i)
4827
4828         do j=iscpstart(i,iint),iscpend(i,iint)
4829           itypj=iabs(itype(j,1))
4830           if (itypj.eq.ntyp1) cycle
4831 ! Uncomment following three lines for SC-p interactions
4832 !         xj=c(1,nres+j)-xi
4833 !         yj=c(2,nres+j)-yi
4834 !         zj=c(3,nres+j)-zi
4835 ! Uncomment following three lines for Ca-p interactions
4836 !          xj=c(1,j)-xi
4837 !          yj=c(2,j)-yi
4838 !          zj=c(3,j)-zi
4839           xj=c(1,j)
4840           yj=c(2,j)
4841           zj=c(3,j)
4842           xj=mod(xj,boxxsize)
4843           if (xj.lt.0) xj=xj+boxxsize
4844           yj=mod(yj,boxysize)
4845           if (yj.lt.0) yj=yj+boxysize
4846           zj=mod(zj,boxzsize)
4847           if (zj.lt.0) zj=zj+boxzsize
4848       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4849       xj_safe=xj
4850       yj_safe=yj
4851       zj_safe=zj
4852       subchap=0
4853       do xshift=-1,1
4854       do yshift=-1,1
4855       do zshift=-1,1
4856           xj=xj_safe+xshift*boxxsize
4857           yj=yj_safe+yshift*boxysize
4858           zj=zj_safe+zshift*boxzsize
4859           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4860           if(dist_temp.lt.dist_init) then
4861             dist_init=dist_temp
4862             xj_temp=xj
4863             yj_temp=yj
4864             zj_temp=zj
4865             subchap=1
4866           endif
4867        enddo
4868        enddo
4869        enddo
4870        if (subchap.eq.1) then
4871           xj=xj_temp-xi
4872           yj=yj_temp-yi
4873           zj=zj_temp-zi
4874        else
4875           xj=xj_safe-xi
4876           yj=yj_safe-yi
4877           zj=zj_safe-zi
4878        endif
4879
4880           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4881           rij=dsqrt(1.0d0/rrij)
4882             sss_ele_cut=sscale_ele(rij)
4883             sss_ele_grad=sscagrad_ele(rij)
4884 !            print *,sss_ele_cut,sss_ele_grad,&
4885 !            (rij),r_cut_ele,rlamb_ele
4886             if (sss_ele_cut.le.0.0) cycle
4887           fac=rrij**expon2
4888           e1=fac*fac*aad(itypj,iteli)
4889           e2=fac*bad(itypj,iteli)
4890           if (iabs(j-i) .le. 2) then
4891             e1=scal14*e1
4892             e2=scal14*e2
4893             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
4894           endif
4895           evdwij=e1+e2
4896           evdw2=evdw2+evdwij*sss_ele_cut
4897 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
4898 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
4899           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4900              'evdw2',i,j,evdwij
4901 !
4902 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4903 !
4904           fac=-(evdwij+e1)*rrij*sss_ele_cut
4905           fac=fac+evdwij*sss_ele_grad/rij/expon
4906           ggg(1)=xj*fac
4907           ggg(2)=yj*fac
4908           ggg(3)=zj*fac
4909 !grad          if (j.lt.i) then
4910 !d          write (iout,*) 'j<i'
4911 ! Uncomment following three lines for SC-p interactions
4912 !           do k=1,3
4913 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4914 !           enddo
4915 !grad          else
4916 !d          write (iout,*) 'j>i'
4917 !grad            do k=1,3
4918 !grad              ggg(k)=-ggg(k)
4919 ! Uncomment following line for SC-p interactions
4920 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4921 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4922 !grad            enddo
4923 !grad          endif
4924 !grad          do k=1,3
4925 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4926 !grad          enddo
4927 !grad          kstart=min0(i+1,j)
4928 !grad          kend=max0(i-1,j-1)
4929 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4930 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4931 !grad          do k=kstart,kend
4932 !grad            do l=1,3
4933 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4934 !grad            enddo
4935 !grad          enddo
4936           do k=1,3
4937             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4938             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4939           enddo
4940         enddo
4941
4942         enddo ! iint
4943       enddo ! i
4944       do i=1,nct
4945         do j=1,3
4946           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4947           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4948           gradx_scp(j,i)=expon*gradx_scp(j,i)
4949         enddo
4950       enddo
4951 !******************************************************************************
4952 !
4953 !                              N O T E !!!
4954 !
4955 ! To save time the factor EXPON has been extracted from ALL components
4956 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
4957 ! use!
4958 !
4959 !******************************************************************************
4960       return
4961       end subroutine escp
4962 !-----------------------------------------------------------------------------
4963       subroutine edis(ehpb)
4964 !
4965 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4966 !
4967 !      implicit real*8 (a-h,o-z)
4968 !      include 'DIMENSIONS'
4969 !      include 'COMMON.SBRIDGE'
4970 !      include 'COMMON.CHAIN'
4971 !      include 'COMMON.DERIV'
4972 !      include 'COMMON.VAR'
4973 !      include 'COMMON.INTERACT'
4974 !      include 'COMMON.IOUNITS'
4975       real(kind=8),dimension(3) :: ggg
4976 !el local variables
4977       integer :: i,j,ii,jj,iii,jjj,k
4978       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
4979
4980       ehpb=0.0D0
4981 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4982 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
4983       if (link_end.eq.0) return
4984       do i=link_start,link_end
4985 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4986 ! CA-CA distance used in regularization of structure.
4987         ii=ihpb(i)
4988         jj=jhpb(i)
4989 ! iii and jjj point to the residues for which the distance is assigned.
4990         if (ii.gt.nres) then
4991           iii=ii-nres
4992           jjj=jj-nres
4993         else
4994           iii=ii
4995           jjj=jj
4996         endif
4997 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4998 !     &    dhpb(i),dhpb1(i),forcon(i)
4999 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5000 !    distance and angle dependent SS bond potential.
5001 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5002 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5003         if (.not.dyn_ss .and. i.le.nss) then
5004 ! 15/02/13 CC dynamic SSbond - additional check
5005          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5006         iabs(itype(jjj,1)).eq.1) then
5007           call ssbond_ene(iii,jjj,eij)
5008           ehpb=ehpb+2*eij
5009 !d          write (iout,*) "eij",eij
5010          endif
5011         else if (ii.gt.nres .and. jj.gt.nres) then
5012 !c Restraints from contact prediction
5013           dd=dist(ii,jj)
5014           if (constr_dist.eq.11) then
5015             ehpb=ehpb+fordepth(i)**4.0d0 &
5016                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5017             fac=fordepth(i)**4.0d0 &
5018                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5019           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5020             ehpb,fordepth(i),dd
5021            else
5022           if (dhpb1(i).gt.0.0d0) then
5023             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5024             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5025 !c            write (iout,*) "beta nmr",
5026 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5027           else
5028             dd=dist(ii,jj)
5029             rdis=dd-dhpb(i)
5030 !C Get the force constant corresponding to this distance.
5031             waga=forcon(i)
5032 !C Calculate the contribution to energy.
5033             ehpb=ehpb+waga*rdis*rdis
5034 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5035 !C
5036 !C Evaluate gradient.
5037 !C
5038             fac=waga*rdis/dd
5039           endif
5040           endif
5041           do j=1,3
5042             ggg(j)=fac*(c(j,jj)-c(j,ii))
5043           enddo
5044           do j=1,3
5045             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5046             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5047           enddo
5048           do k=1,3
5049             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5050             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5051           enddo
5052         else
5053           dd=dist(ii,jj)
5054           if (constr_dist.eq.11) then
5055             ehpb=ehpb+fordepth(i)**4.0d0 &
5056                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5057             fac=fordepth(i)**4.0d0 &
5058                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5059           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5060          ehpb,fordepth(i),dd
5061            else
5062           if (dhpb1(i).gt.0.0d0) then
5063             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5064             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5065 !c            write (iout,*) "alph nmr",
5066 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5067           else
5068             rdis=dd-dhpb(i)
5069 !C Get the force constant corresponding to this distance.
5070             waga=forcon(i)
5071 !C Calculate the contribution to energy.
5072             ehpb=ehpb+waga*rdis*rdis
5073 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5074 !C
5075 !C Evaluate gradient.
5076 !C
5077             fac=waga*rdis/dd
5078           endif
5079           endif
5080
5081             do j=1,3
5082               ggg(j)=fac*(c(j,jj)-c(j,ii))
5083             enddo
5084 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5085 !C If this is a SC-SC distance, we need to calculate the contributions to the
5086 !C Cartesian gradient in the SC vectors (ghpbx).
5087           if (iii.lt.ii) then
5088           do j=1,3
5089             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5090             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5091           enddo
5092           endif
5093 !cgrad        do j=iii,jjj-1
5094 !cgrad          do k=1,3
5095 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5096 !cgrad          enddo
5097 !cgrad        enddo
5098           do k=1,3
5099             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5100             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5101           enddo
5102         endif
5103       enddo
5104       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5105
5106       return
5107       end subroutine edis
5108 !-----------------------------------------------------------------------------
5109       subroutine ssbond_ene(i,j,eij)
5110 !
5111 ! Calculate the distance and angle dependent SS-bond potential energy
5112 ! using a free-energy function derived based on RHF/6-31G** ab initio
5113 ! calculations of diethyl disulfide.
5114 !
5115 ! A. Liwo and U. Kozlowska, 11/24/03
5116 !
5117 !      implicit real*8 (a-h,o-z)
5118 !      include 'DIMENSIONS'
5119 !      include 'COMMON.SBRIDGE'
5120 !      include 'COMMON.CHAIN'
5121 !      include 'COMMON.DERIV'
5122 !      include 'COMMON.LOCAL'
5123 !      include 'COMMON.INTERACT'
5124 !      include 'COMMON.VAR'
5125 !      include 'COMMON.IOUNITS'
5126       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5127 !el local variables
5128       integer :: i,j,itypi,itypj,k
5129       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5130                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5131                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5132                    cosphi,ggk
5133
5134       itypi=iabs(itype(i,1))
5135       xi=c(1,nres+i)
5136       yi=c(2,nres+i)
5137       zi=c(3,nres+i)
5138       dxi=dc_norm(1,nres+i)
5139       dyi=dc_norm(2,nres+i)
5140       dzi=dc_norm(3,nres+i)
5141 !      dsci_inv=dsc_inv(itypi)
5142       dsci_inv=vbld_inv(nres+i)
5143       itypj=iabs(itype(j,1))
5144 !      dscj_inv=dsc_inv(itypj)
5145       dscj_inv=vbld_inv(nres+j)
5146       xj=c(1,nres+j)-xi
5147       yj=c(2,nres+j)-yi
5148       zj=c(3,nres+j)-zi
5149       dxj=dc_norm(1,nres+j)
5150       dyj=dc_norm(2,nres+j)
5151       dzj=dc_norm(3,nres+j)
5152       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5153       rij=dsqrt(rrij)
5154       erij(1)=xj*rij
5155       erij(2)=yj*rij
5156       erij(3)=zj*rij
5157       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5158       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5159       om12=dxi*dxj+dyi*dyj+dzi*dzj
5160       do k=1,3
5161         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5162         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5163       enddo
5164       rij=1.0d0/rij
5165       deltad=rij-d0cm
5166       deltat1=1.0d0-om1
5167       deltat2=1.0d0+om2
5168       deltat12=om2-om1+2.0d0
5169       cosphi=om12-om1*om2
5170       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5171         +akct*deltad*deltat12 &
5172         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5173 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5174 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5175 !     &  " deltat12",deltat12," eij",eij
5176       ed=2*akcm*deltad+akct*deltat12
5177       pom1=akct*deltad
5178       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5179       eom1=-2*akth*deltat1-pom1-om2*pom2
5180       eom2= 2*akth*deltat2+pom1-om1*pom2
5181       eom12=pom2
5182       do k=1,3
5183         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5184         ghpbx(k,i)=ghpbx(k,i)-ggk &
5185                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5186                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5187         ghpbx(k,j)=ghpbx(k,j)+ggk &
5188                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5189                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5190         ghpbc(k,i)=ghpbc(k,i)-ggk
5191         ghpbc(k,j)=ghpbc(k,j)+ggk
5192       enddo
5193 !
5194 ! Calculate the components of the gradient in DC and X
5195 !
5196 !grad      do k=i,j-1
5197 !grad        do l=1,3
5198 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5199 !grad        enddo
5200 !grad      enddo
5201       return
5202       end subroutine ssbond_ene
5203 !-----------------------------------------------------------------------------
5204       subroutine ebond(estr)
5205 !
5206 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5207 !
5208 !      implicit real*8 (a-h,o-z)
5209 !      include 'DIMENSIONS'
5210 !      include 'COMMON.LOCAL'
5211 !      include 'COMMON.GEO'
5212 !      include 'COMMON.INTERACT'
5213 !      include 'COMMON.DERIV'
5214 !      include 'COMMON.VAR'
5215 !      include 'COMMON.CHAIN'
5216 !      include 'COMMON.IOUNITS'
5217 !      include 'COMMON.NAMES'
5218 !      include 'COMMON.FFIELD'
5219 !      include 'COMMON.CONTROL'
5220 !      include 'COMMON.SETUP'
5221       real(kind=8),dimension(3) :: u,ud
5222 !el local variables
5223       integer :: i,j,iti,nbi,k
5224       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5225                    uprod1,uprod2
5226
5227       estr=0.0d0
5228       estr1=0.0d0
5229 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5230 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5231
5232       do i=ibondp_start,ibondp_end
5233         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5234         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5235 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5236 !C          do j=1,3
5237 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5238 !C            *dc(j,i-1)/vbld(i)
5239 !C          enddo
5240 !C          if (energy_dec) write(iout,*) &
5241 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5242         diff = vbld(i)-vbldpDUM
5243         else
5244         diff = vbld(i)-vbldp0
5245         endif
5246         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5247            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5248         estr=estr+diff*diff
5249         do j=1,3
5250           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5251         enddo
5252 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5253 !        endif
5254       enddo
5255       estr=0.5d0*AKP*estr+estr1
5256 !      print *,"estr_bb",estr,AKP
5257 !
5258 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5259 !
5260       do i=ibond_start,ibond_end
5261         iti=iabs(itype(i,1))
5262         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5263         if (iti.ne.10 .and. iti.ne.ntyp1) then
5264           nbi=nbondterm(iti)
5265           if (nbi.eq.1) then
5266             diff=vbld(i+nres)-vbldsc0(1,iti)
5267             if (energy_dec) write (iout,*) &
5268             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5269             AKSC(1,iti),AKSC(1,iti)*diff*diff
5270             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5271 !            print *,"estr_sc",estr
5272             do j=1,3
5273               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5274             enddo
5275           else
5276             do j=1,nbi
5277               diff=vbld(i+nres)-vbldsc0(j,iti)
5278               ud(j)=aksc(j,iti)*diff
5279               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5280             enddo
5281             uprod=u(1)
5282             do j=2,nbi
5283               uprod=uprod*u(j)
5284             enddo
5285             usum=0.0d0
5286             usumsqder=0.0d0
5287             do j=1,nbi
5288               uprod1=1.0d0
5289               uprod2=1.0d0
5290               do k=1,nbi
5291                 if (k.ne.j) then
5292                   uprod1=uprod1*u(k)
5293                   uprod2=uprod2*u(k)*u(k)
5294                 endif
5295               enddo
5296               usum=usum+uprod1
5297               usumsqder=usumsqder+ud(j)*uprod2
5298             enddo
5299             estr=estr+uprod/usum
5300 !            print *,"estr_sc",estr,i
5301
5302              if (energy_dec) write (iout,*) &
5303             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5304             AKSC(1,iti),uprod/usum
5305             do j=1,3
5306              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5307             enddo
5308           endif
5309         endif
5310       enddo
5311       return
5312       end subroutine ebond
5313 #ifdef CRYST_THETA
5314 !-----------------------------------------------------------------------------
5315       subroutine ebend(etheta)
5316 !
5317 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5318 ! angles gamma and its derivatives in consecutive thetas and gammas.
5319 !
5320       use comm_calcthet
5321 !      implicit real*8 (a-h,o-z)
5322 !      include 'DIMENSIONS'
5323 !      include 'COMMON.LOCAL'
5324 !      include 'COMMON.GEO'
5325 !      include 'COMMON.INTERACT'
5326 !      include 'COMMON.DERIV'
5327 !      include 'COMMON.VAR'
5328 !      include 'COMMON.CHAIN'
5329 !      include 'COMMON.IOUNITS'
5330 !      include 'COMMON.NAMES'
5331 !      include 'COMMON.FFIELD'
5332 !      include 'COMMON.CONTROL'
5333 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5334 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5335 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5336 !el      integer :: it
5337 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5338 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5339 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5340 !el local variables
5341       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5342        ichir21,ichir22
5343       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5344        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5345        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5346       real(kind=8),dimension(2) :: y,z
5347
5348       delta=0.02d0*pi
5349 !      time11=dexp(-2*time)
5350 !      time12=1.0d0
5351       etheta=0.0D0
5352 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5353       do i=ithet_start,ithet_end
5354         if (itype(i-1,1).eq.ntyp1) cycle
5355 ! Zero the energy function and its derivative at 0 or pi.
5356         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5357         it=itype(i-1,1)
5358         ichir1=isign(1,itype(i-2,1))
5359         ichir2=isign(1,itype(i,1))
5360          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5361          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5362          if (itype(i-1,1).eq.10) then
5363           itype1=isign(10,itype(i-2,1))
5364           ichir11=isign(1,itype(i-2,1))
5365           ichir12=isign(1,itype(i-2,1))
5366           itype2=isign(10,itype(i,1))
5367           ichir21=isign(1,itype(i,1))
5368           ichir22=isign(1,itype(i,1))
5369          endif
5370
5371         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5372 #ifdef OSF
5373           phii=phi(i)
5374           if (phii.ne.phii) phii=150.0
5375 #else
5376           phii=phi(i)
5377 #endif
5378           y(1)=dcos(phii)
5379           y(2)=dsin(phii)
5380         else
5381           y(1)=0.0D0
5382           y(2)=0.0D0
5383         endif
5384         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5385 #ifdef OSF
5386           phii1=phi(i+1)
5387           if (phii1.ne.phii1) phii1=150.0
5388           phii1=pinorm(phii1)
5389           z(1)=cos(phii1)
5390 #else
5391           phii1=phi(i+1)
5392           z(1)=dcos(phii1)
5393 #endif
5394           z(2)=dsin(phii1)
5395         else
5396           z(1)=0.0D0
5397           z(2)=0.0D0
5398         endif
5399 ! Calculate the "mean" value of theta from the part of the distribution
5400 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5401 ! In following comments this theta will be referred to as t_c.
5402         thet_pred_mean=0.0d0
5403         do k=1,2
5404             athetk=athet(k,it,ichir1,ichir2)
5405             bthetk=bthet(k,it,ichir1,ichir2)
5406           if (it.eq.10) then
5407              athetk=athet(k,itype1,ichir11,ichir12)
5408              bthetk=bthet(k,itype2,ichir21,ichir22)
5409           endif
5410          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5411         enddo
5412         dthett=thet_pred_mean*ssd
5413         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5414 ! Derivatives of the "mean" values in gamma1 and gamma2.
5415         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5416                +athet(2,it,ichir1,ichir2)*y(1))*ss
5417         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5418                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5419          if (it.eq.10) then
5420         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5421              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5422         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5423                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5424          endif
5425         if (theta(i).gt.pi-delta) then
5426           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5427                E_tc0)
5428           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5429           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5430           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5431               E_theta)
5432           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5433               E_tc)
5434         else if (theta(i).lt.delta) then
5435           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5436           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5437           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5438               E_theta)
5439           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5440           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5441               E_tc)
5442         else
5443           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5444               E_theta,E_tc)
5445         endif
5446         etheta=etheta+ethetai
5447         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5448             'ebend',i,ethetai
5449         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5450         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5451         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5452       enddo
5453 ! Ufff.... We've done all this!!!
5454       return
5455       end subroutine ebend
5456 !-----------------------------------------------------------------------------
5457       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5458
5459       use comm_calcthet
5460 !      implicit real*8 (a-h,o-z)
5461 !      include 'DIMENSIONS'
5462 !      include 'COMMON.LOCAL'
5463 !      include 'COMMON.IOUNITS'
5464 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5465 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5466 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5467       integer :: i,j,k
5468       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5469 !el      integer :: it
5470 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5471 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5472 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5473 !el local variables
5474       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5475        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5476
5477 ! Calculate the contributions to both Gaussian lobes.
5478 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5479 ! The "polynomial part" of the "standard deviation" of this part of
5480 ! the distribution.
5481         sig=polthet(3,it)
5482         do j=2,0,-1
5483           sig=sig*thet_pred_mean+polthet(j,it)
5484         enddo
5485 ! Derivative of the "interior part" of the "standard deviation of the"
5486 ! gamma-dependent Gaussian lobe in t_c.
5487         sigtc=3*polthet(3,it)
5488         do j=2,1,-1
5489           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5490         enddo
5491         sigtc=sig*sigtc
5492 ! Set the parameters of both Gaussian lobes of the distribution.
5493 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5494         fac=sig*sig+sigc0(it)
5495         sigcsq=fac+fac
5496         sigc=1.0D0/sigcsq
5497 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5498         sigsqtc=-4.0D0*sigcsq*sigtc
5499 !       print *,i,sig,sigtc,sigsqtc
5500 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5501         sigtc=-sigtc/(fac*fac)
5502 ! Following variable is sigma(t_c)**(-2)
5503         sigcsq=sigcsq*sigcsq
5504         sig0i=sig0(it)
5505         sig0inv=1.0D0/sig0i**2
5506         delthec=thetai-thet_pred_mean
5507         delthe0=thetai-theta0i
5508         term1=-0.5D0*sigcsq*delthec*delthec
5509         term2=-0.5D0*sig0inv*delthe0*delthe0
5510 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5511 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5512 ! to the energy (this being the log of the distribution) at the end of energy
5513 ! term evaluation for this virtual-bond angle.
5514         if (term1.gt.term2) then
5515           termm=term1
5516           term2=dexp(term2-termm)
5517           term1=1.0d0
5518         else
5519           termm=term2
5520           term1=dexp(term1-termm)
5521           term2=1.0d0
5522         endif
5523 ! The ratio between the gamma-independent and gamma-dependent lobes of
5524 ! the distribution is a Gaussian function of thet_pred_mean too.
5525         diffak=gthet(2,it)-thet_pred_mean
5526         ratak=diffak/gthet(3,it)**2
5527         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5528 ! Let's differentiate it in thet_pred_mean NOW.
5529         aktc=ak*ratak
5530 ! Now put together the distribution terms to make complete distribution.
5531         termexp=term1+ak*term2
5532         termpre=sigc+ak*sig0i
5533 ! Contribution of the bending energy from this theta is just the -log of
5534 ! the sum of the contributions from the two lobes and the pre-exponential
5535 ! factor. Simple enough, isn't it?
5536         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5537 ! NOW the derivatives!!!
5538 ! 6/6/97 Take into account the deformation.
5539         E_theta=(delthec*sigcsq*term1 &
5540              +ak*delthe0*sig0inv*term2)/termexp
5541         E_tc=((sigtc+aktc*sig0i)/termpre &
5542             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5543              aktc*term2)/termexp)
5544       return
5545       end subroutine theteng
5546 #else
5547 !-----------------------------------------------------------------------------
5548       subroutine ebend(etheta,ethetacnstr)
5549 !
5550 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5551 ! angles gamma and its derivatives in consecutive thetas and gammas.
5552 ! ab initio-derived potentials from
5553 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5554 !
5555 !      implicit real*8 (a-h,o-z)
5556 !      include 'DIMENSIONS'
5557 !      include 'COMMON.LOCAL'
5558 !      include 'COMMON.GEO'
5559 !      include 'COMMON.INTERACT'
5560 !      include 'COMMON.DERIV'
5561 !      include 'COMMON.VAR'
5562 !      include 'COMMON.CHAIN'
5563 !      include 'COMMON.IOUNITS'
5564 !      include 'COMMON.NAMES'
5565 !      include 'COMMON.FFIELD'
5566 !      include 'COMMON.CONTROL'
5567       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5568       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5569       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5570       logical :: lprn=.false., lprn1=.false.
5571 !el local variables
5572       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5573       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5574       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5575 ! local variables for constrains
5576       real(kind=8) :: difi,thetiii
5577        integer itheta
5578
5579       etheta=0.0D0
5580       do i=ithet_start,ithet_end
5581         if (itype(i-1,1).eq.ntyp1) cycle
5582         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5583         if (iabs(itype(i+1,1)).eq.20) iblock=2
5584         if (iabs(itype(i+1,1)).ne.20) iblock=1
5585         dethetai=0.0d0
5586         dephii=0.0d0
5587         dephii1=0.0d0
5588         theti2=0.5d0*theta(i)
5589         ityp2=ithetyp((itype(i-1,1)))
5590         do k=1,nntheterm
5591           coskt(k)=dcos(k*theti2)
5592           sinkt(k)=dsin(k*theti2)
5593         enddo
5594         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5595 #ifdef OSF
5596           phii=phi(i)
5597           if (phii.ne.phii) phii=150.0
5598 #else
5599           phii=phi(i)
5600 #endif
5601           ityp1=ithetyp((itype(i-2,1)))
5602 ! propagation of chirality for glycine type
5603           do k=1,nsingle
5604             cosph1(k)=dcos(k*phii)
5605             sinph1(k)=dsin(k*phii)
5606           enddo
5607         else
5608           phii=0.0d0
5609           ityp1=ithetyp(itype(i-2,1))
5610           do k=1,nsingle
5611             cosph1(k)=0.0d0
5612             sinph1(k)=0.0d0
5613           enddo
5614         endif
5615         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5616 #ifdef OSF
5617           phii1=phi(i+1)
5618           if (phii1.ne.phii1) phii1=150.0
5619           phii1=pinorm(phii1)
5620 #else
5621           phii1=phi(i+1)
5622 #endif
5623           ityp3=ithetyp((itype(i,1)))
5624           do k=1,nsingle
5625             cosph2(k)=dcos(k*phii1)
5626             sinph2(k)=dsin(k*phii1)
5627           enddo
5628         else
5629           phii1=0.0d0
5630           ityp3=ithetyp(itype(i,1))
5631           do k=1,nsingle
5632             cosph2(k)=0.0d0
5633             sinph2(k)=0.0d0
5634           enddo
5635         endif
5636         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5637         do k=1,ndouble
5638           do l=1,k-1
5639             ccl=cosph1(l)*cosph2(k-l)
5640             ssl=sinph1(l)*sinph2(k-l)
5641             scl=sinph1(l)*cosph2(k-l)
5642             csl=cosph1(l)*sinph2(k-l)
5643             cosph1ph2(l,k)=ccl-ssl
5644             cosph1ph2(k,l)=ccl+ssl
5645             sinph1ph2(l,k)=scl+csl
5646             sinph1ph2(k,l)=scl-csl
5647           enddo
5648         enddo
5649         if (lprn) then
5650         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5651           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5652         write (iout,*) "coskt and sinkt"
5653         do k=1,nntheterm
5654           write (iout,*) k,coskt(k),sinkt(k)
5655         enddo
5656         endif
5657         do k=1,ntheterm
5658           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5659           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5660             *coskt(k)
5661           if (lprn) &
5662           write (iout,*) "k",k,&
5663            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5664            " ethetai",ethetai
5665         enddo
5666         if (lprn) then
5667         write (iout,*) "cosph and sinph"
5668         do k=1,nsingle
5669           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5670         enddo
5671         write (iout,*) "cosph1ph2 and sinph2ph2"
5672         do k=2,ndouble
5673           do l=1,k-1
5674             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5675                sinph1ph2(l,k),sinph1ph2(k,l)
5676           enddo
5677         enddo
5678         write(iout,*) "ethetai",ethetai
5679         endif
5680         do m=1,ntheterm2
5681           do k=1,nsingle
5682             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5683                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5684                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5685                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5686             ethetai=ethetai+sinkt(m)*aux
5687             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5688             dephii=dephii+k*sinkt(m)* &
5689                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5690                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5691             dephii1=dephii1+k*sinkt(m)* &
5692                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5693                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5694             if (lprn) &
5695             write (iout,*) "m",m," k",k," bbthet", &
5696                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5697                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5698                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5699                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5700           enddo
5701         enddo
5702         if (lprn) &
5703         write(iout,*) "ethetai",ethetai
5704         do m=1,ntheterm3
5705           do k=2,ndouble
5706             do l=1,k-1
5707               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5708                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5709                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5710                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5711               ethetai=ethetai+sinkt(m)*aux
5712               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5713               dephii=dephii+l*sinkt(m)* &
5714                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5715                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5716                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5717                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5718               dephii1=dephii1+(k-l)*sinkt(m)* &
5719                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5720                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5721                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5722                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5723               if (lprn) then
5724               write (iout,*) "m",m," k",k," l",l," ffthet",&
5725                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5726                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5727                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5728                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5729                   " ethetai",ethetai
5730               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5731                   cosph1ph2(k,l)*sinkt(m),&
5732                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5733               endif
5734             enddo
5735           enddo
5736         enddo
5737 10      continue
5738 !        lprn1=.true.
5739         if (lprn1) &
5740           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5741          i,theta(i)*rad2deg,phii*rad2deg,&
5742          phii1*rad2deg,ethetai
5743 !        lprn1=.false.
5744         etheta=etheta+ethetai
5745         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5746                                     'ebend',i,ethetai
5747         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5748         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5749         gloc(nphi+i-2,icg)=wang*dethetai
5750       enddo
5751 !-----------thete constrains
5752 !      if (tor_mode.ne.2) then
5753       ethetacnstr=0.0d0
5754 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5755       do i=ithetaconstr_start,ithetaconstr_end
5756         itheta=itheta_constr(i)
5757         thetiii=theta(itheta)
5758         difi=pinorm(thetiii-theta_constr0(i))
5759         if (difi.gt.theta_drange(i)) then
5760           difi=difi-theta_drange(i)
5761           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5762           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5763          +for_thet_constr(i)*difi**3
5764         else if (difi.lt.-drange(i)) then
5765           difi=difi+drange(i)
5766           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5767           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5768          +for_thet_constr(i)*difi**3
5769         else
5770           difi=0.0
5771         endif
5772        if (energy_dec) then
5773         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5774          i,itheta,rad2deg*thetiii, &
5775          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5776          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5777          gloc(itheta+nphi-2,icg)
5778         endif
5779       enddo
5780 !      endif
5781
5782       return
5783       end subroutine ebend
5784 #endif
5785 #ifdef CRYST_SC
5786 !-----------------------------------------------------------------------------
5787       subroutine esc(escloc)
5788 ! Calculate the local energy of a side chain and its derivatives in the
5789 ! corresponding virtual-bond valence angles THETA and the spherical angles
5790 ! ALPHA and OMEGA.
5791 !
5792       use comm_sccalc
5793 !      implicit real*8 (a-h,o-z)
5794 !      include 'DIMENSIONS'
5795 !      include 'COMMON.GEO'
5796 !      include 'COMMON.LOCAL'
5797 !      include 'COMMON.VAR'
5798 !      include 'COMMON.INTERACT'
5799 !      include 'COMMON.DERIV'
5800 !      include 'COMMON.CHAIN'
5801 !      include 'COMMON.IOUNITS'
5802 !      include 'COMMON.NAMES'
5803 !      include 'COMMON.FFIELD'
5804 !      include 'COMMON.CONTROL'
5805       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5806          ddersc0,ddummy,xtemp,temp
5807 !el      real(kind=8) :: time11,time12,time112,theti
5808       real(kind=8) :: escloc,delta
5809 !el      integer :: it,nlobit
5810 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5811 !el local variables
5812       integer :: i,k
5813       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5814        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5815       delta=0.02d0*pi
5816       escloc=0.0D0
5817 !     write (iout,'(a)') 'ESC'
5818       do i=loc_start,loc_end
5819         it=itype(i,1)
5820         if (it.eq.ntyp1) cycle
5821         if (it.eq.10) goto 1
5822         nlobit=nlob(iabs(it))
5823 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5824 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5825         theti=theta(i+1)-pipol
5826         x(1)=dtan(theti)
5827         x(2)=alph(i)
5828         x(3)=omeg(i)
5829
5830         if (x(2).gt.pi-delta) then
5831           xtemp(1)=x(1)
5832           xtemp(2)=pi-delta
5833           xtemp(3)=x(3)
5834           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5835           xtemp(2)=pi
5836           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5837           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5838               escloci,dersc(2))
5839           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5840               ddersc0(1),dersc(1))
5841           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5842               ddersc0(3),dersc(3))
5843           xtemp(2)=pi-delta
5844           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5845           xtemp(2)=pi
5846           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5847           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5848                   dersc0(2),esclocbi,dersc02)
5849           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5850                   dersc12,dersc01)
5851           call splinthet(x(2),0.5d0*delta,ss,ssd)
5852           dersc0(1)=dersc01
5853           dersc0(2)=dersc02
5854           dersc0(3)=0.0d0
5855           do k=1,3
5856             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5857           enddo
5858           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5859 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5860 !    &             esclocbi,ss,ssd
5861           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5862 !         escloci=esclocbi
5863 !         write (iout,*) escloci
5864         else if (x(2).lt.delta) then
5865           xtemp(1)=x(1)
5866           xtemp(2)=delta
5867           xtemp(3)=x(3)
5868           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5869           xtemp(2)=0.0d0
5870           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5871           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
5872               escloci,dersc(2))
5873           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5874               ddersc0(1),dersc(1))
5875           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
5876               ddersc0(3),dersc(3))
5877           xtemp(2)=delta
5878           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5879           xtemp(2)=0.0d0
5880           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5881           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
5882                   dersc0(2),esclocbi,dersc02)
5883           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5884                   dersc12,dersc01)
5885           dersc0(1)=dersc01
5886           dersc0(2)=dersc02
5887           dersc0(3)=0.0d0
5888           call splinthet(x(2),0.5d0*delta,ss,ssd)
5889           do k=1,3
5890             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5891           enddo
5892           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5893 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5894 !    &             esclocbi,ss,ssd
5895           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5896 !         write (iout,*) escloci
5897         else
5898           call enesc(x,escloci,dersc,ddummy,.false.)
5899         endif
5900
5901         escloc=escloc+escloci
5902         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5903            'escloc',i,escloci
5904 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5905
5906         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
5907          wscloc*dersc(1)
5908         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5909         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5910     1   continue
5911       enddo
5912       return
5913       end subroutine esc
5914 !-----------------------------------------------------------------------------
5915       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5916
5917       use comm_sccalc
5918 !      implicit real*8 (a-h,o-z)
5919 !      include 'DIMENSIONS'
5920 !      include 'COMMON.GEO'
5921 !      include 'COMMON.LOCAL'
5922 !      include 'COMMON.IOUNITS'
5923 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5924       real(kind=8),dimension(3) :: x,z,dersc,ddersc
5925       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
5926       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
5927       real(kind=8) :: escloci
5928       logical :: mixed
5929 !el local variables
5930       integer :: j,iii,l,k !el,it,nlobit
5931       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
5932 !el       time11,time12,time112
5933 !       write (iout,*) 'it=',it,' nlobit=',nlobit
5934         escloc_i=0.0D0
5935         do j=1,3
5936           dersc(j)=0.0D0
5937           if (mixed) ddersc(j)=0.0d0
5938         enddo
5939         x3=x(3)
5940
5941 ! Because of periodicity of the dependence of the SC energy in omega we have
5942 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5943 ! To avoid underflows, first compute & store the exponents.
5944
5945         do iii=-1,1
5946
5947           x(3)=x3+iii*dwapi
5948
5949           do j=1,nlobit
5950             do k=1,3
5951               z(k)=x(k)-censc(k,j,it)
5952             enddo
5953             do k=1,3
5954               Axk=0.0D0
5955               do l=1,3
5956                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5957               enddo
5958               Ax(k,j,iii)=Axk
5959             enddo
5960             expfac=0.0D0
5961             do k=1,3
5962               expfac=expfac+Ax(k,j,iii)*z(k)
5963             enddo
5964             contr(j,iii)=expfac
5965           enddo ! j
5966
5967         enddo ! iii
5968
5969         x(3)=x3
5970 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5971 ! subsequent NaNs and INFs in energy calculation.
5972 ! Find the largest exponent
5973         emin=contr(1,-1)
5974         do iii=-1,1
5975           do j=1,nlobit
5976             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5977           enddo
5978         enddo
5979         emin=0.5D0*emin
5980 !d      print *,'it=',it,' emin=',emin
5981
5982 ! Compute the contribution to SC energy and derivatives
5983         do iii=-1,1
5984
5985           do j=1,nlobit
5986 #ifdef OSF
5987             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5988             if(adexp.ne.adexp) adexp=1.0
5989             expfac=dexp(adexp)
5990 #else
5991             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5992 #endif
5993 !d          print *,'j=',j,' expfac=',expfac
5994             escloc_i=escloc_i+expfac
5995             do k=1,3
5996               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5997             enddo
5998             if (mixed) then
5999               do k=1,3,2
6000                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6001                   +gaussc(k,2,j,it))*expfac
6002               enddo
6003             endif
6004           enddo
6005
6006         enddo ! iii
6007
6008         dersc(1)=dersc(1)/cos(theti)**2
6009         ddersc(1)=ddersc(1)/cos(theti)**2
6010         ddersc(3)=ddersc(3)
6011
6012         escloci=-(dlog(escloc_i)-emin)
6013         do j=1,3
6014           dersc(j)=dersc(j)/escloc_i
6015         enddo
6016         if (mixed) then
6017           do j=1,3,2
6018             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6019           enddo
6020         endif
6021       return
6022       end subroutine enesc
6023 !-----------------------------------------------------------------------------
6024       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6025
6026       use comm_sccalc
6027 !      implicit real*8 (a-h,o-z)
6028 !      include 'DIMENSIONS'
6029 !      include 'COMMON.GEO'
6030 !      include 'COMMON.LOCAL'
6031 !      include 'COMMON.IOUNITS'
6032 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6033       real(kind=8),dimension(3) :: x,z,dersc
6034       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6035       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6036       real(kind=8) :: escloci,dersc12,emin
6037       logical :: mixed
6038 !el local varables
6039       integer :: j,k,l !el,it,nlobit
6040       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6041
6042       escloc_i=0.0D0
6043
6044       do j=1,3
6045         dersc(j)=0.0D0
6046       enddo
6047
6048       do j=1,nlobit
6049         do k=1,2
6050           z(k)=x(k)-censc(k,j,it)
6051         enddo
6052         z(3)=dwapi
6053         do k=1,3
6054           Axk=0.0D0
6055           do l=1,3
6056             Axk=Axk+gaussc(l,k,j,it)*z(l)
6057           enddo
6058           Ax(k,j)=Axk
6059         enddo
6060         expfac=0.0D0
6061         do k=1,3
6062           expfac=expfac+Ax(k,j)*z(k)
6063         enddo
6064         contr(j)=expfac
6065       enddo ! j
6066
6067 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6068 ! subsequent NaNs and INFs in energy calculation.
6069 ! Find the largest exponent
6070       emin=contr(1)
6071       do j=1,nlobit
6072         if (emin.gt.contr(j)) emin=contr(j)
6073       enddo
6074       emin=0.5D0*emin
6075
6076 ! Compute the contribution to SC energy and derivatives
6077
6078       dersc12=0.0d0
6079       do j=1,nlobit
6080         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6081         escloc_i=escloc_i+expfac
6082         do k=1,2
6083           dersc(k)=dersc(k)+Ax(k,j)*expfac
6084         enddo
6085         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6086                   +gaussc(1,2,j,it))*expfac
6087         dersc(3)=0.0d0
6088       enddo
6089
6090       dersc(1)=dersc(1)/cos(theti)**2
6091       dersc12=dersc12/cos(theti)**2
6092       escloci=-(dlog(escloc_i)-emin)
6093       do j=1,2
6094         dersc(j)=dersc(j)/escloc_i
6095       enddo
6096       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6097       return
6098       end subroutine enesc_bound
6099 #else
6100 !-----------------------------------------------------------------------------
6101       subroutine esc(escloc)
6102 ! Calculate the local energy of a side chain and its derivatives in the
6103 ! corresponding virtual-bond valence angles THETA and the spherical angles
6104 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6105 ! added by Urszula Kozlowska. 07/11/2007
6106 !
6107       use comm_sccalc
6108 !      implicit real*8 (a-h,o-z)
6109 !      include 'DIMENSIONS'
6110 !      include 'COMMON.GEO'
6111 !      include 'COMMON.LOCAL'
6112 !      include 'COMMON.VAR'
6113 !      include 'COMMON.SCROT'
6114 !      include 'COMMON.INTERACT'
6115 !      include 'COMMON.DERIV'
6116 !      include 'COMMON.CHAIN'
6117 !      include 'COMMON.IOUNITS'
6118 !      include 'COMMON.NAMES'
6119 !      include 'COMMON.FFIELD'
6120 !      include 'COMMON.CONTROL'
6121 !      include 'COMMON.VECTORS'
6122       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6123       real(kind=8),dimension(65) :: x
6124       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6125          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6126       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6127       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6128          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6129 !el local variables
6130       integer :: i,j,k !el,it,nlobit
6131       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6132 !el      real(kind=8) :: time11,time12,time112,theti
6133 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6134       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6135                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6136                    sumene1x,sumene2x,sumene3x,sumene4x,&
6137                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6138                    cosfac2xx,sinfac2yy
6139 #ifdef DEBUG
6140       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6141                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6142                    de_dt_num
6143 #endif
6144 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6145
6146       delta=0.02d0*pi
6147       escloc=0.0D0
6148       do i=loc_start,loc_end
6149         if (itype(i,1).eq.ntyp1) cycle
6150         costtab(i+1) =dcos(theta(i+1))
6151         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6152         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6153         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6154         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6155         cosfac=dsqrt(cosfac2)
6156         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6157         sinfac=dsqrt(sinfac2)
6158         it=iabs(itype(i,1))
6159         if (it.eq.10) goto 1
6160 !
6161 !  Compute the axes of tghe local cartesian coordinates system; store in
6162 !   x_prime, y_prime and z_prime
6163 !
6164         do j=1,3
6165           x_prime(j) = 0.00
6166           y_prime(j) = 0.00
6167           z_prime(j) = 0.00
6168         enddo
6169 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6170 !     &   dc_norm(3,i+nres)
6171         do j = 1,3
6172           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6173           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6174         enddo
6175         do j = 1,3
6176           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6177         enddo
6178 !       write (2,*) "i",i
6179 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6180 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6181 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6182 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6183 !      & " xy",scalar(x_prime(1),y_prime(1)),
6184 !      & " xz",scalar(x_prime(1),z_prime(1)),
6185 !      & " yy",scalar(y_prime(1),y_prime(1)),
6186 !      & " yz",scalar(y_prime(1),z_prime(1)),
6187 !      & " zz",scalar(z_prime(1),z_prime(1))
6188 !
6189 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6190 ! to local coordinate system. Store in xx, yy, zz.
6191 !
6192         xx=0.0d0
6193         yy=0.0d0
6194         zz=0.0d0
6195         do j = 1,3
6196           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6197           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6198           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6199         enddo
6200
6201         xxtab(i)=xx
6202         yytab(i)=yy
6203         zztab(i)=zz
6204 !
6205 ! Compute the energy of the ith side cbain
6206 !
6207 !        write (2,*) "xx",xx," yy",yy," zz",zz
6208         it=iabs(itype(i,1))
6209         do j = 1,65
6210           x(j) = sc_parmin(j,it)
6211         enddo
6212 #ifdef CHECK_COORD
6213 !c diagnostics - remove later
6214         xx1 = dcos(alph(2))
6215         yy1 = dsin(alph(2))*dcos(omeg(2))
6216         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6217         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6218           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6219           xx1,yy1,zz1
6220 !,"  --- ", xx_w,yy_w,zz_w
6221 ! end diagnostics
6222 #endif
6223         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6224          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6225          + x(10)*yy*zz
6226         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6227          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6228          + x(20)*yy*zz
6229         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6230          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6231          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6232          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6233          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6234          +x(40)*xx*yy*zz
6235         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6236          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6237          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6238          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6239          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6240          +x(60)*xx*yy*zz
6241         dsc_i   = 0.743d0+x(61)
6242         dp2_i   = 1.9d0+x(62)
6243         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6244                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6245         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6246                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6247         s1=(1+x(63))/(0.1d0 + dscp1)
6248         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6249         s2=(1+x(65))/(0.1d0 + dscp2)
6250         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6251         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6252       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6253 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6254 !     &   sumene4,
6255 !     &   dscp1,dscp2,sumene
6256 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6257         escloc = escloc + sumene
6258 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6259 !     & ,zz,xx,yy
6260 !#define DEBUG
6261 #ifdef DEBUG
6262 !
6263 ! This section to check the numerical derivatives of the energy of ith side
6264 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6265 ! #define DEBUG in the code to turn it on.
6266 !
6267         write (2,*) "sumene               =",sumene
6268         aincr=1.0d-7
6269         xxsave=xx
6270         xx=xx+aincr
6271         write (2,*) xx,yy,zz
6272         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6273         de_dxx_num=(sumenep-sumene)/aincr
6274         xx=xxsave
6275         write (2,*) "xx+ sumene from enesc=",sumenep
6276         yysave=yy
6277         yy=yy+aincr
6278         write (2,*) xx,yy,zz
6279         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6280         de_dyy_num=(sumenep-sumene)/aincr
6281         yy=yysave
6282         write (2,*) "yy+ sumene from enesc=",sumenep
6283         zzsave=zz
6284         zz=zz+aincr
6285         write (2,*) xx,yy,zz
6286         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6287         de_dzz_num=(sumenep-sumene)/aincr
6288         zz=zzsave
6289         write (2,*) "zz+ sumene from enesc=",sumenep
6290         costsave=cost2tab(i+1)
6291         sintsave=sint2tab(i+1)
6292         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6293         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6294         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6295         de_dt_num=(sumenep-sumene)/aincr
6296         write (2,*) " t+ sumene from enesc=",sumenep
6297         cost2tab(i+1)=costsave
6298         sint2tab(i+1)=sintsave
6299 ! End of diagnostics section.
6300 #endif
6301 !
6302 ! Compute the gradient of esc
6303 !
6304 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6305         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6306         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6307         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6308         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6309         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6310         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6311         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6312         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6313         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6314            *(pom_s1/dscp1+pom_s16*dscp1**4)
6315         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6316            *(pom_s2/dscp2+pom_s26*dscp2**4)
6317         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6318         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6319         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6320         +x(40)*yy*zz
6321         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6322         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6323         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6324         +x(60)*yy*zz
6325         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6326               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6327               +(pom1+pom2)*pom_dx
6328 #ifdef DEBUG
6329         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6330 #endif
6331 !
6332         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6333         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6334         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6335         +x(40)*xx*zz
6336         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6337         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6338         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6339         +x(59)*zz**2 +x(60)*xx*zz
6340         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6341               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6342               +(pom1-pom2)*pom_dy
6343 #ifdef DEBUG
6344         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6345 #endif
6346 !
6347         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6348         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6349         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6350         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6351         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6352         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6353         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6354         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6355 #ifdef DEBUG
6356         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6357 #endif
6358 !
6359         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6360         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6361         +pom1*pom_dt1+pom2*pom_dt2
6362 #ifdef DEBUG
6363         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6364 #endif
6365 !
6366 !
6367        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6368        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6369        cosfac2xx=cosfac2*xx
6370        sinfac2yy=sinfac2*yy
6371        do k = 1,3
6372          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6373             vbld_inv(i+1)
6374          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6375             vbld_inv(i)
6376          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6377          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6378 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6379 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6380 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6381 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6382          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6383          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6384          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6385          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6386          dZZ_Ci1(k)=0.0d0
6387          dZZ_Ci(k)=0.0d0
6388          do j=1,3
6389            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6390            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6391            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6392            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6393          enddo
6394
6395          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6396          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6397          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6398          (z_prime(k)-zz*dC_norm(k,i+nres))
6399 !
6400          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6401          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6402        enddo
6403
6404        do k=1,3
6405          dXX_Ctab(k,i)=dXX_Ci(k)
6406          dXX_C1tab(k,i)=dXX_Ci1(k)
6407          dYY_Ctab(k,i)=dYY_Ci(k)
6408          dYY_C1tab(k,i)=dYY_Ci1(k)
6409          dZZ_Ctab(k,i)=dZZ_Ci(k)
6410          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6411          dXX_XYZtab(k,i)=dXX_XYZ(k)
6412          dYY_XYZtab(k,i)=dYY_XYZ(k)
6413          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6414        enddo
6415
6416        do k = 1,3
6417 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6418 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6419 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6420 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6421 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6422 !     &    dt_dci(k)
6423 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6424 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6425          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6426           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6427          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6428           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6429          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6430           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6431        enddo
6432 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6433 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6434
6435 ! to check gradient call subroutine check_grad
6436
6437     1 continue
6438       enddo
6439       return
6440       end subroutine esc
6441 !-----------------------------------------------------------------------------
6442       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6443 !      implicit none
6444       real(kind=8),dimension(65) :: x
6445       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6446         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6447
6448       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6449         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6450         + x(10)*yy*zz
6451       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6452         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6453         + x(20)*yy*zz
6454       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6455         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6456         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6457         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6458         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6459         +x(40)*xx*yy*zz
6460       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6461         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6462         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6463         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6464         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6465         +x(60)*xx*yy*zz
6466       dsc_i   = 0.743d0+x(61)
6467       dp2_i   = 1.9d0+x(62)
6468       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6469                 *(xx*cost2+yy*sint2))
6470       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6471                 *(xx*cost2-yy*sint2))
6472       s1=(1+x(63))/(0.1d0 + dscp1)
6473       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6474       s2=(1+x(65))/(0.1d0 + dscp2)
6475       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6476       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6477        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6478       enesc=sumene
6479       return
6480       end function enesc
6481 #endif
6482 !-----------------------------------------------------------------------------
6483       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6484 !
6485 ! This procedure calculates two-body contact function g(rij) and its derivative:
6486 !
6487 !           eps0ij                                     !       x < -1
6488 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6489 !            0                                         !       x > 1
6490 !
6491 ! where x=(rij-r0ij)/delta
6492 !
6493 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6494 !
6495 !      implicit none
6496       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6497       real(kind=8) :: x,x2,x4,delta
6498 !     delta=0.02D0*r0ij
6499 !      delta=0.2D0*r0ij
6500       x=(rij-r0ij)/delta
6501       if (x.lt.-1.0D0) then
6502         fcont=eps0ij
6503         fprimcont=0.0D0
6504       else if (x.le.1.0D0) then
6505         x2=x*x
6506         x4=x2*x2
6507         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6508         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6509       else
6510         fcont=0.0D0
6511         fprimcont=0.0D0
6512       endif
6513       return
6514       end subroutine gcont
6515 !-----------------------------------------------------------------------------
6516       subroutine splinthet(theti,delta,ss,ssder)
6517 !      implicit real*8 (a-h,o-z)
6518 !      include 'DIMENSIONS'
6519 !      include 'COMMON.VAR'
6520 !      include 'COMMON.GEO'
6521       real(kind=8) :: theti,delta,ss,ssder
6522       real(kind=8) :: thetup,thetlow
6523       thetup=pi-delta
6524       thetlow=delta
6525       if (theti.gt.pipol) then
6526         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6527       else
6528         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6529         ssder=-ssder
6530       endif
6531       return
6532       end subroutine splinthet
6533 !-----------------------------------------------------------------------------
6534       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6535 !      implicit none
6536       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6537       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6538       a1=fprim0*delta/(f1-f0)
6539       a2=3.0d0-2.0d0*a1
6540       a3=a1-2.0d0
6541       ksi=(x-x0)/delta
6542       ksi2=ksi*ksi
6543       ksi3=ksi2*ksi
6544       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6545       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6546       return
6547       end subroutine spline1
6548 !-----------------------------------------------------------------------------
6549       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6550 !      implicit none
6551       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6552       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6553       ksi=(x-x0)/delta
6554       ksi2=ksi*ksi
6555       ksi3=ksi2*ksi
6556       a1=fprim0x*delta
6557       a2=3*(f1x-f0x)-2*fprim0x*delta
6558       a3=fprim0x*delta-2*(f1x-f0x)
6559       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6560       return
6561       end subroutine spline2
6562 !-----------------------------------------------------------------------------
6563 #ifdef CRYST_TOR
6564 !-----------------------------------------------------------------------------
6565       subroutine etor(etors,edihcnstr)
6566 !      implicit real*8 (a-h,o-z)
6567 !      include 'DIMENSIONS'
6568 !      include 'COMMON.VAR'
6569 !      include 'COMMON.GEO'
6570 !      include 'COMMON.LOCAL'
6571 !      include 'COMMON.TORSION'
6572 !      include 'COMMON.INTERACT'
6573 !      include 'COMMON.DERIV'
6574 !      include 'COMMON.CHAIN'
6575 !      include 'COMMON.NAMES'
6576 !      include 'COMMON.IOUNITS'
6577 !      include 'COMMON.FFIELD'
6578 !      include 'COMMON.TORCNSTR'
6579 !      include 'COMMON.CONTROL'
6580       real(kind=8) :: etors,edihcnstr
6581       logical :: lprn
6582 !el local variables
6583       integer :: i,j,
6584       real(kind=8) :: phii,fac,etors_ii
6585
6586 ! Set lprn=.true. for debugging
6587       lprn=.false.
6588 !      lprn=.true.
6589       etors=0.0D0
6590       do i=iphi_start,iphi_end
6591       etors_ii=0.0D0
6592         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6593             .or. itype(i,1).eq.ntyp1) cycle
6594         itori=itortyp(itype(i-2,1))
6595         itori1=itortyp(itype(i-1,1))
6596         phii=phi(i)
6597         gloci=0.0D0
6598 ! Proline-Proline pair is a special case...
6599         if (itori.eq.3 .and. itori1.eq.3) then
6600           if (phii.gt.-dwapi3) then
6601             cosphi=dcos(3*phii)
6602             fac=1.0D0/(1.0D0-cosphi)
6603             etorsi=v1(1,3,3)*fac
6604             etorsi=etorsi+etorsi
6605             etors=etors+etorsi-v1(1,3,3)
6606             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6607             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6608           endif
6609           do j=1,3
6610             v1ij=v1(j+1,itori,itori1)
6611             v2ij=v2(j+1,itori,itori1)
6612             cosphi=dcos(j*phii)
6613             sinphi=dsin(j*phii)
6614             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6615             if (energy_dec) etors_ii=etors_ii+ &
6616                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6617             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6618           enddo
6619         else
6620           do j=1,nterm_old
6621             v1ij=v1(j,itori,itori1)
6622             v2ij=v2(j,itori,itori1)
6623             cosphi=dcos(j*phii)
6624             sinphi=dsin(j*phii)
6625             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6626             if (energy_dec) etors_ii=etors_ii+ &
6627                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6628             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6629           enddo
6630         endif
6631         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6632              'etor',i,etors_ii
6633         if (lprn) &
6634         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6635         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6636         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6637         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6638 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6639       enddo
6640 ! 6/20/98 - dihedral angle constraints
6641       edihcnstr=0.0d0
6642       do i=1,ndih_constr
6643         itori=idih_constr(i)
6644         phii=phi(itori)
6645         difi=phii-phi0(i)
6646         if (difi.gt.drange(i)) then
6647           difi=difi-drange(i)
6648           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6649           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6650         else if (difi.lt.-drange(i)) then
6651           difi=difi+drange(i)
6652           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6653           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6654         endif
6655 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6656 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6657       enddo
6658 !      write (iout,*) 'edihcnstr',edihcnstr
6659       return
6660       end subroutine etor
6661 !-----------------------------------------------------------------------------
6662       subroutine etor_d(etors_d)
6663       real(kind=8) :: etors_d
6664       etors_d=0.0d0
6665       return
6666       end subroutine etor_d
6667 #else
6668 !-----------------------------------------------------------------------------
6669       subroutine etor(etors,edihcnstr)
6670 !      implicit real*8 (a-h,o-z)
6671 !      include 'DIMENSIONS'
6672 !      include 'COMMON.VAR'
6673 !      include 'COMMON.GEO'
6674 !      include 'COMMON.LOCAL'
6675 !      include 'COMMON.TORSION'
6676 !      include 'COMMON.INTERACT'
6677 !      include 'COMMON.DERIV'
6678 !      include 'COMMON.CHAIN'
6679 !      include 'COMMON.NAMES'
6680 !      include 'COMMON.IOUNITS'
6681 !      include 'COMMON.FFIELD'
6682 !      include 'COMMON.TORCNSTR'
6683 !      include 'COMMON.CONTROL'
6684       real(kind=8) :: etors,edihcnstr
6685       logical :: lprn
6686 !el local variables
6687       integer :: i,j,iblock,itori,itori1
6688       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6689                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6690 ! Set lprn=.true. for debugging
6691       lprn=.false.
6692 !     lprn=.true.
6693       etors=0.0D0
6694       do i=iphi_start,iphi_end
6695         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6696              .or. itype(i-3,1).eq.ntyp1 &
6697              .or. itype(i,1).eq.ntyp1) cycle
6698         etors_ii=0.0D0
6699          if (iabs(itype(i,1)).eq.20) then
6700          iblock=2
6701          else
6702          iblock=1
6703          endif
6704         itori=itortyp(itype(i-2,1))
6705         itori1=itortyp(itype(i-1,1))
6706         phii=phi(i)
6707         gloci=0.0D0
6708 ! Regular cosine and sine terms
6709         do j=1,nterm(itori,itori1,iblock)
6710           v1ij=v1(j,itori,itori1,iblock)
6711           v2ij=v2(j,itori,itori1,iblock)
6712           cosphi=dcos(j*phii)
6713           sinphi=dsin(j*phii)
6714           etors=etors+v1ij*cosphi+v2ij*sinphi
6715           if (energy_dec) etors_ii=etors_ii+ &
6716                      v1ij*cosphi+v2ij*sinphi
6717           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6718         enddo
6719 ! Lorentz terms
6720 !                         v1
6721 !  E = SUM ----------------------------------- - v1
6722 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6723 !
6724         cosphi=dcos(0.5d0*phii)
6725         sinphi=dsin(0.5d0*phii)
6726         do j=1,nlor(itori,itori1,iblock)
6727           vl1ij=vlor1(j,itori,itori1)
6728           vl2ij=vlor2(j,itori,itori1)
6729           vl3ij=vlor3(j,itori,itori1)
6730           pom=vl2ij*cosphi+vl3ij*sinphi
6731           pom1=1.0d0/(pom*pom+1.0d0)
6732           etors=etors+vl1ij*pom1
6733           if (energy_dec) etors_ii=etors_ii+ &
6734                      vl1ij*pom1
6735           pom=-pom*pom1*pom1
6736           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6737         enddo
6738 ! Subtract the constant term
6739         etors=etors-v0(itori,itori1,iblock)
6740           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6741                'etor',i,etors_ii-v0(itori,itori1,iblock)
6742         if (lprn) &
6743         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6744         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6745         (v1(j,itori,itori1,iblock),j=1,6),&
6746         (v2(j,itori,itori1,iblock),j=1,6)
6747         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6748 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6749       enddo
6750 ! 6/20/98 - dihedral angle constraints
6751       edihcnstr=0.0d0
6752 !      do i=1,ndih_constr
6753       do i=idihconstr_start,idihconstr_end
6754         itori=idih_constr(i)
6755         phii=phi(itori)
6756         difi=pinorm(phii-phi0(i))
6757         if (difi.gt.drange(i)) then
6758           difi=difi-drange(i)
6759           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6760           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6761         else if (difi.lt.-drange(i)) then
6762           difi=difi+drange(i)
6763           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6764           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6765         else
6766           difi=0.0
6767         endif
6768 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6769 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6770 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6771       enddo
6772 !d       write (iout,*) 'edihcnstr',edihcnstr
6773       return
6774       end subroutine etor
6775 !-----------------------------------------------------------------------------
6776       subroutine etor_d(etors_d)
6777 ! 6/23/01 Compute double torsional energy
6778 !      implicit real*8 (a-h,o-z)
6779 !      include 'DIMENSIONS'
6780 !      include 'COMMON.VAR'
6781 !      include 'COMMON.GEO'
6782 !      include 'COMMON.LOCAL'
6783 !      include 'COMMON.TORSION'
6784 !      include 'COMMON.INTERACT'
6785 !      include 'COMMON.DERIV'
6786 !      include 'COMMON.CHAIN'
6787 !      include 'COMMON.NAMES'
6788 !      include 'COMMON.IOUNITS'
6789 !      include 'COMMON.FFIELD'
6790 !      include 'COMMON.TORCNSTR'
6791       real(kind=8) :: etors_d,etors_d_ii
6792       logical :: lprn
6793 !el local variables
6794       integer :: i,j,k,l,itori,itori1,itori2,iblock
6795       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6796                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6797                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6798                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6799 ! Set lprn=.true. for debugging
6800       lprn=.false.
6801 !     lprn=.true.
6802       etors_d=0.0D0
6803 !      write(iout,*) "a tu??"
6804       do i=iphid_start,iphid_end
6805         etors_d_ii=0.0D0
6806         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6807             .or. itype(i-3,1).eq.ntyp1 &
6808             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6809         itori=itortyp(itype(i-2,1))
6810         itori1=itortyp(itype(i-1,1))
6811         itori2=itortyp(itype(i,1))
6812         phii=phi(i)
6813         phii1=phi(i+1)
6814         gloci1=0.0D0
6815         gloci2=0.0D0
6816         iblock=1
6817         if (iabs(itype(i+1,1)).eq.20) iblock=2
6818
6819 ! Regular cosine and sine terms
6820         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6821           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6822           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6823           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6824           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6825           cosphi1=dcos(j*phii)
6826           sinphi1=dsin(j*phii)
6827           cosphi2=dcos(j*phii1)
6828           sinphi2=dsin(j*phii1)
6829           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6830            v2cij*cosphi2+v2sij*sinphi2
6831           if (energy_dec) etors_d_ii=etors_d_ii+ &
6832            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6833           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6834           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6835         enddo
6836         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6837           do l=1,k-1
6838             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6839             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6840             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6841             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6842             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6843             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6844             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6845             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6846             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6847               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6848             if (energy_dec) etors_d_ii=etors_d_ii+ &
6849               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6850               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6851             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6852               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6853             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6854               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6855           enddo
6856         enddo
6857         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6858                             'etor_d',i,etors_d_ii
6859         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6860         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6861       enddo
6862       return
6863       end subroutine etor_d
6864 #endif
6865 !-----------------------------------------------------------------------------
6866       subroutine eback_sc_corr(esccor)
6867 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
6868 !        conformational states; temporarily implemented as differences
6869 !        between UNRES torsional potentials (dependent on three types of
6870 !        residues) and the torsional potentials dependent on all 20 types
6871 !        of residues computed from AM1  energy surfaces of terminally-blocked
6872 !        amino-acid residues.
6873 !      implicit real*8 (a-h,o-z)
6874 !      include 'DIMENSIONS'
6875 !      include 'COMMON.VAR'
6876 !      include 'COMMON.GEO'
6877 !      include 'COMMON.LOCAL'
6878 !      include 'COMMON.TORSION'
6879 !      include 'COMMON.SCCOR'
6880 !      include 'COMMON.INTERACT'
6881 !      include 'COMMON.DERIV'
6882 !      include 'COMMON.CHAIN'
6883 !      include 'COMMON.NAMES'
6884 !      include 'COMMON.IOUNITS'
6885 !      include 'COMMON.FFIELD'
6886 !      include 'COMMON.CONTROL'
6887       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
6888                    cosphi,sinphi
6889       logical :: lprn
6890       integer :: i,interty,j,isccori,isccori1,intertyp
6891 ! Set lprn=.true. for debugging
6892       lprn=.false.
6893 !      lprn=.true.
6894 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6895       esccor=0.0D0
6896       do i=itau_start,itau_end
6897         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
6898         esccor_ii=0.0D0
6899         isccori=isccortyp(itype(i-2,1))
6900         isccori1=isccortyp(itype(i-1,1))
6901
6902 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6903         phii=phi(i)
6904         do intertyp=1,3 !intertyp
6905          esccor_ii=0.0D0
6906 !c Added 09 May 2012 (Adasko)
6907 !c  Intertyp means interaction type of backbone mainchain correlation:
6908 !   1 = SC...Ca...Ca...Ca
6909 !   2 = Ca...Ca...Ca...SC
6910 !   3 = SC...Ca...Ca...SCi
6911         gloci=0.0D0
6912         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
6913             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
6914             (itype(i-1,1).eq.ntyp1))) &
6915           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
6916            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
6917            .or.(itype(i,1).eq.ntyp1))) &
6918           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
6919             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
6920             (itype(i-3,1).eq.ntyp1)))) cycle
6921         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
6922         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
6923        cycle
6924        do j=1,nterm_sccor(isccori,isccori1)
6925           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6926           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6927           cosphi=dcos(j*tauangle(intertyp,i))
6928           sinphi=dsin(j*tauangle(intertyp,i))
6929           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6930           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6931           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6932         enddo
6933         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
6934                                 'esccor',i,intertyp,esccor_ii
6935 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6936         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6937         if (lprn) &
6938         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6939         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
6940         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
6941         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6942         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6943        enddo !intertyp
6944       enddo
6945
6946       return
6947       end subroutine eback_sc_corr
6948 !-----------------------------------------------------------------------------
6949       subroutine multibody(ecorr)
6950 ! This subroutine calculates multi-body contributions to energy following
6951 ! the idea of Skolnick et al. If side chains I and J make a contact and
6952 ! at the same time side chains I+1 and J+1 make a contact, an extra
6953 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6954 !      implicit real*8 (a-h,o-z)
6955 !      include 'DIMENSIONS'
6956 !      include 'COMMON.IOUNITS'
6957 !      include 'COMMON.DERIV'
6958 !      include 'COMMON.INTERACT'
6959 !      include 'COMMON.CONTACTS'
6960       real(kind=8),dimension(3) :: gx,gx1
6961       logical :: lprn
6962       real(kind=8) :: ecorr
6963       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
6964 ! Set lprn=.true. for debugging
6965       lprn=.false.
6966
6967       if (lprn) then
6968         write (iout,'(a)') 'Contact function values:'
6969         do i=nnt,nct-2
6970           write (iout,'(i2,20(1x,i2,f10.5))') &
6971               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6972         enddo
6973       endif
6974       ecorr=0.0D0
6975
6976 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6977 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6978       do i=nnt,nct
6979         do j=1,3
6980           gradcorr(j,i)=0.0D0
6981           gradxorr(j,i)=0.0D0
6982         enddo
6983       enddo
6984       do i=nnt,nct-2
6985
6986         DO ISHIFT = 3,4
6987
6988         i1=i+ishift
6989         num_conti=num_cont(i)
6990         num_conti1=num_cont(i1)
6991         do jj=1,num_conti
6992           j=jcont(jj,i)
6993           do kk=1,num_conti1
6994             j1=jcont(kk,i1)
6995             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6996 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6997 !d   &                   ' ishift=',ishift
6998 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6999 ! The system gains extra energy.
7000               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7001             endif   ! j1==j+-ishift
7002           enddo     ! kk
7003         enddo       ! jj
7004
7005         ENDDO ! ISHIFT
7006
7007       enddo         ! i
7008       return
7009       end subroutine multibody
7010 !-----------------------------------------------------------------------------
7011       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7012 !      implicit real*8 (a-h,o-z)
7013 !      include 'DIMENSIONS'
7014 !      include 'COMMON.IOUNITS'
7015 !      include 'COMMON.DERIV'
7016 !      include 'COMMON.INTERACT'
7017 !      include 'COMMON.CONTACTS'
7018       real(kind=8),dimension(3) :: gx,gx1
7019       logical :: lprn
7020       integer :: i,j,k,l,jj,kk,m,ll
7021       real(kind=8) :: eij,ekl
7022       lprn=.false.
7023       eij=facont(jj,i)
7024       ekl=facont(kk,k)
7025 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7026 ! Calculate the multi-body contribution to energy.
7027 ! Calculate multi-body contributions to the gradient.
7028 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7029 !d   & k,l,(gacont(m,kk,k),m=1,3)
7030       do m=1,3
7031         gx(m) =ekl*gacont(m,jj,i)
7032         gx1(m)=eij*gacont(m,kk,k)
7033         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7034         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7035         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7036         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7037       enddo
7038       do m=i,j-1
7039         do ll=1,3
7040           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7041         enddo
7042       enddo
7043       do m=k,l-1
7044         do ll=1,3
7045           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7046         enddo
7047       enddo
7048       esccorr=-eij*ekl
7049       return
7050       end function esccorr
7051 !-----------------------------------------------------------------------------
7052       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7053 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7054 !      implicit real*8 (a-h,o-z)
7055 !      include 'DIMENSIONS'
7056 !      include 'COMMON.IOUNITS'
7057 #ifdef MPI
7058       include "mpif.h"
7059 !      integer :: maxconts !max_cont=maxconts  =nres/4
7060       integer,parameter :: max_dim=26
7061       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7062       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7063 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7064 !el      common /przechowalnia/ zapas
7065       integer :: status(MPI_STATUS_SIZE)
7066       integer,dimension((nres/4)*2) :: req !maxconts*2
7067       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7068 #endif
7069 !      include 'COMMON.SETUP'
7070 !      include 'COMMON.FFIELD'
7071 !      include 'COMMON.DERIV'
7072 !      include 'COMMON.INTERACT'
7073 !      include 'COMMON.CONTACTS'
7074 !      include 'COMMON.CONTROL'
7075 !      include 'COMMON.LOCAL'
7076       real(kind=8),dimension(3) :: gx,gx1
7077       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7078       logical :: lprn,ldone
7079 !el local variables
7080       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7081               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7082
7083 ! Set lprn=.true. for debugging
7084       lprn=.false.
7085 #ifdef MPI
7086 !      maxconts=nres/4
7087       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7088       n_corr=0
7089       n_corr1=0
7090       if (nfgtasks.le.1) goto 30
7091       if (lprn) then
7092         write (iout,'(a)') 'Contact function values before RECEIVE:'
7093         do i=nnt,nct-2
7094           write (iout,'(2i3,50(1x,i2,f5.2))') &
7095           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7096           j=1,num_cont_hb(i))
7097         enddo
7098       endif
7099       call flush(iout)
7100       do i=1,ntask_cont_from
7101         ncont_recv(i)=0
7102       enddo
7103       do i=1,ntask_cont_to
7104         ncont_sent(i)=0
7105       enddo
7106 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7107 !     & ntask_cont_to
7108 ! Make the list of contacts to send to send to other procesors
7109 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7110 !      call flush(iout)
7111       do i=iturn3_start,iturn3_end
7112 !        write (iout,*) "make contact list turn3",i," num_cont",
7113 !     &    num_cont_hb(i)
7114         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7115       enddo
7116       do i=iturn4_start,iturn4_end
7117 !        write (iout,*) "make contact list turn4",i," num_cont",
7118 !     &   num_cont_hb(i)
7119         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7120       enddo
7121       do ii=1,nat_sent
7122         i=iat_sent(ii)
7123 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7124 !     &    num_cont_hb(i)
7125         do j=1,num_cont_hb(i)
7126         do k=1,4
7127           jjc=jcont_hb(j,i)
7128           iproc=iint_sent_local(k,jjc,ii)
7129 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7130           if (iproc.gt.0) then
7131             ncont_sent(iproc)=ncont_sent(iproc)+1
7132             nn=ncont_sent(iproc)
7133             zapas(1,nn,iproc)=i
7134             zapas(2,nn,iproc)=jjc
7135             zapas(3,nn,iproc)=facont_hb(j,i)
7136             zapas(4,nn,iproc)=ees0p(j,i)
7137             zapas(5,nn,iproc)=ees0m(j,i)
7138             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7139             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7140             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7141             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7142             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7143             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7144             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7145             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7146             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7147             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7148             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7149             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7150             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7151             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7152             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7153             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7154             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7155             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7156             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7157             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7158             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7159           endif
7160         enddo
7161         enddo
7162       enddo
7163       if (lprn) then
7164       write (iout,*) &
7165         "Numbers of contacts to be sent to other processors",&
7166         (ncont_sent(i),i=1,ntask_cont_to)
7167       write (iout,*) "Contacts sent"
7168       do ii=1,ntask_cont_to
7169         nn=ncont_sent(ii)
7170         iproc=itask_cont_to(ii)
7171         write (iout,*) nn," contacts to processor",iproc,&
7172          " of CONT_TO_COMM group"
7173         do i=1,nn
7174           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7175         enddo
7176       enddo
7177       call flush(iout)
7178       endif
7179       CorrelType=477
7180       CorrelID=fg_rank+1
7181       CorrelType1=478
7182       CorrelID1=nfgtasks+fg_rank+1
7183       ireq=0
7184 ! Receive the numbers of needed contacts from other processors
7185       do ii=1,ntask_cont_from
7186         iproc=itask_cont_from(ii)
7187         ireq=ireq+1
7188         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7189           FG_COMM,req(ireq),IERR)
7190       enddo
7191 !      write (iout,*) "IRECV ended"
7192 !      call flush(iout)
7193 ! Send the number of contacts needed by other processors
7194       do ii=1,ntask_cont_to
7195         iproc=itask_cont_to(ii)
7196         ireq=ireq+1
7197         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7198           FG_COMM,req(ireq),IERR)
7199       enddo
7200 !      write (iout,*) "ISEND ended"
7201 !      write (iout,*) "number of requests (nn)",ireq
7202       call flush(iout)
7203       if (ireq.gt.0) &
7204         call MPI_Waitall(ireq,req,status_array,ierr)
7205 !      write (iout,*)
7206 !     &  "Numbers of contacts to be received from other processors",
7207 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7208 !      call flush(iout)
7209 ! Receive contacts
7210       ireq=0
7211       do ii=1,ntask_cont_from
7212         iproc=itask_cont_from(ii)
7213         nn=ncont_recv(ii)
7214 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7215 !     &   " of CONT_TO_COMM group"
7216         call flush(iout)
7217         if (nn.gt.0) then
7218           ireq=ireq+1
7219           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7220           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7221 !          write (iout,*) "ireq,req",ireq,req(ireq)
7222         endif
7223       enddo
7224 ! Send the contacts to processors that need them
7225       do ii=1,ntask_cont_to
7226         iproc=itask_cont_to(ii)
7227         nn=ncont_sent(ii)
7228 !        write (iout,*) nn," contacts to processor",iproc,
7229 !     &   " of CONT_TO_COMM group"
7230         if (nn.gt.0) then
7231           ireq=ireq+1
7232           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7233             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7234 !          write (iout,*) "ireq,req",ireq,req(ireq)
7235 !          do i=1,nn
7236 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7237 !          enddo
7238         endif
7239       enddo
7240 !      write (iout,*) "number of requests (contacts)",ireq
7241 !      write (iout,*) "req",(req(i),i=1,4)
7242 !      call flush(iout)
7243       if (ireq.gt.0) &
7244        call MPI_Waitall(ireq,req,status_array,ierr)
7245       do iii=1,ntask_cont_from
7246         iproc=itask_cont_from(iii)
7247         nn=ncont_recv(iii)
7248         if (lprn) then
7249         write (iout,*) "Received",nn," contacts from processor",iproc,&
7250          " of CONT_FROM_COMM group"
7251         call flush(iout)
7252         do i=1,nn
7253           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7254         enddo
7255         call flush(iout)
7256         endif
7257         do i=1,nn
7258           ii=zapas_recv(1,i,iii)
7259 ! Flag the received contacts to prevent double-counting
7260           jj=-zapas_recv(2,i,iii)
7261 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7262 !          call flush(iout)
7263           nnn=num_cont_hb(ii)+1
7264           num_cont_hb(ii)=nnn
7265           jcont_hb(nnn,ii)=jj
7266           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7267           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7268           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7269           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7270           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7271           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7272           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7273           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7274           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7275           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7276           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7277           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7278           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7279           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7280           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7281           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7282           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7283           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7284           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7285           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7286           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7287           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7288           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7289           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7290         enddo
7291       enddo
7292       call flush(iout)
7293       if (lprn) then
7294         write (iout,'(a)') 'Contact function values after receive:'
7295         do i=nnt,nct-2
7296           write (iout,'(2i3,50(1x,i3,f5.2))') &
7297           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7298           j=1,num_cont_hb(i))
7299         enddo
7300         call flush(iout)
7301       endif
7302    30 continue
7303 #endif
7304       if (lprn) then
7305         write (iout,'(a)') 'Contact function values:'
7306         do i=nnt,nct-2
7307           write (iout,'(2i3,50(1x,i3,f5.2))') &
7308           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7309           j=1,num_cont_hb(i))
7310         enddo
7311       endif
7312       ecorr=0.0D0
7313
7314 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7315 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7316 ! Remove the loop below after debugging !!!
7317       do i=nnt,nct
7318         do j=1,3
7319           gradcorr(j,i)=0.0D0
7320           gradxorr(j,i)=0.0D0
7321         enddo
7322       enddo
7323 ! Calculate the local-electrostatic correlation terms
7324       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7325         i1=i+1
7326         num_conti=num_cont_hb(i)
7327         num_conti1=num_cont_hb(i+1)
7328         do jj=1,num_conti
7329           j=jcont_hb(jj,i)
7330           jp=iabs(j)
7331           do kk=1,num_conti1
7332             j1=jcont_hb(kk,i1)
7333             jp1=iabs(j1)
7334 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7335 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7336             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7337                 .or. j.lt.0 .and. j1.gt.0) .and. &
7338                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7339 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7340 ! The system gains extra energy.
7341               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7342               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7343                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7344               n_corr=n_corr+1
7345             else if (j1.eq.j) then
7346 ! Contacts I-J and I-(J+1) occur simultaneously.
7347 ! The system loses extra energy.
7348 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7349             endif
7350           enddo ! kk
7351           do kk=1,num_conti
7352             j1=jcont_hb(kk,i)
7353 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7354 !    &         ' jj=',jj,' kk=',kk
7355             if (j1.eq.j+1) then
7356 ! Contacts I-J and (I+1)-J occur simultaneously.
7357 ! The system loses extra energy.
7358 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7359             endif ! j1==j+1
7360           enddo ! kk
7361         enddo ! jj
7362       enddo ! i
7363       return
7364       end subroutine multibody_hb
7365 !-----------------------------------------------------------------------------
7366       subroutine add_hb_contact(ii,jj,itask)
7367 !      implicit real*8 (a-h,o-z)
7368 !      include "DIMENSIONS"
7369 !      include "COMMON.IOUNITS"
7370 !      include "COMMON.CONTACTS"
7371 !      integer,parameter :: maxconts=nres/4
7372       integer,parameter :: max_dim=26
7373       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7374 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7375 !      common /przechowalnia/ zapas
7376       integer :: i,j,ii,jj,iproc,nn,jjc
7377       integer,dimension(4) :: itask
7378 !      write (iout,*) "itask",itask
7379       do i=1,2
7380         iproc=itask(i)
7381         if (iproc.gt.0) then
7382           do j=1,num_cont_hb(ii)
7383             jjc=jcont_hb(j,ii)
7384 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7385             if (jjc.eq.jj) then
7386               ncont_sent(iproc)=ncont_sent(iproc)+1
7387               nn=ncont_sent(iproc)
7388               zapas(1,nn,iproc)=ii
7389               zapas(2,nn,iproc)=jjc
7390               zapas(3,nn,iproc)=facont_hb(j,ii)
7391               zapas(4,nn,iproc)=ees0p(j,ii)
7392               zapas(5,nn,iproc)=ees0m(j,ii)
7393               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7394               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7395               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7396               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7397               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7398               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7399               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7400               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7401               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7402               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7403               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7404               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7405               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7406               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7407               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7408               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7409               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7410               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7411               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7412               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7413               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7414               exit
7415             endif
7416           enddo
7417         endif
7418       enddo
7419       return
7420       end subroutine add_hb_contact
7421 !-----------------------------------------------------------------------------
7422       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7423 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7424 !      implicit real*8 (a-h,o-z)
7425 !      include 'DIMENSIONS'
7426 !      include 'COMMON.IOUNITS'
7427       integer,parameter :: max_dim=70
7428 #ifdef MPI
7429       include "mpif.h"
7430 !      integer :: maxconts !max_cont=maxconts=nres/4
7431       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7432       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7433 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7434 !      common /przechowalnia/ zapas
7435       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7436         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7437         ierr,iii,nnn
7438 #endif
7439 !      include 'COMMON.SETUP'
7440 !      include 'COMMON.FFIELD'
7441 !      include 'COMMON.DERIV'
7442 !      include 'COMMON.LOCAL'
7443 !      include 'COMMON.INTERACT'
7444 !      include 'COMMON.CONTACTS'
7445 !      include 'COMMON.CHAIN'
7446 !      include 'COMMON.CONTROL'
7447       real(kind=8),dimension(3) :: gx,gx1
7448       integer,dimension(nres) :: num_cont_hb_old
7449       logical :: lprn,ldone
7450 !EL      double precision eello4,eello5,eelo6,eello_turn6
7451 !EL      external eello4,eello5,eello6,eello_turn6
7452 !el local variables
7453       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7454               j1,jp1,i1,num_conti1
7455       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7456       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7457
7458 ! Set lprn=.true. for debugging
7459       lprn=.false.
7460       eturn6=0.0d0
7461 #ifdef MPI
7462 !      maxconts=nres/4
7463       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7464       do i=1,nres
7465         num_cont_hb_old(i)=num_cont_hb(i)
7466       enddo
7467       n_corr=0
7468       n_corr1=0
7469       if (nfgtasks.le.1) goto 30
7470       if (lprn) then
7471         write (iout,'(a)') 'Contact function values before RECEIVE:'
7472         do i=nnt,nct-2
7473           write (iout,'(2i3,50(1x,i2,f5.2))') &
7474           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7475           j=1,num_cont_hb(i))
7476         enddo
7477       endif
7478       call flush(iout)
7479       do i=1,ntask_cont_from
7480         ncont_recv(i)=0
7481       enddo
7482       do i=1,ntask_cont_to
7483         ncont_sent(i)=0
7484       enddo
7485 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7486 !     & ntask_cont_to
7487 ! Make the list of contacts to send to send to other procesors
7488       do i=iturn3_start,iturn3_end
7489 !        write (iout,*) "make contact list turn3",i," num_cont",
7490 !     &    num_cont_hb(i)
7491         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7492       enddo
7493       do i=iturn4_start,iturn4_end
7494 !        write (iout,*) "make contact list turn4",i," num_cont",
7495 !     &   num_cont_hb(i)
7496         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7497       enddo
7498       do ii=1,nat_sent
7499         i=iat_sent(ii)
7500 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7501 !     &    num_cont_hb(i)
7502         do j=1,num_cont_hb(i)
7503         do k=1,4
7504           jjc=jcont_hb(j,i)
7505           iproc=iint_sent_local(k,jjc,ii)
7506 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7507           if (iproc.ne.0) then
7508             ncont_sent(iproc)=ncont_sent(iproc)+1
7509             nn=ncont_sent(iproc)
7510             zapas(1,nn,iproc)=i
7511             zapas(2,nn,iproc)=jjc
7512             zapas(3,nn,iproc)=d_cont(j,i)
7513             ind=3
7514             do kk=1,3
7515               ind=ind+1
7516               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7517             enddo
7518             do kk=1,2
7519               do ll=1,2
7520                 ind=ind+1
7521                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7522               enddo
7523             enddo
7524             do jj=1,5
7525               do kk=1,3
7526                 do ll=1,2
7527                   do mm=1,2
7528                     ind=ind+1
7529                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7530                   enddo
7531                 enddo
7532               enddo
7533             enddo
7534           endif
7535         enddo
7536         enddo
7537       enddo
7538       if (lprn) then
7539       write (iout,*) &
7540         "Numbers of contacts to be sent to other processors",&
7541         (ncont_sent(i),i=1,ntask_cont_to)
7542       write (iout,*) "Contacts sent"
7543       do ii=1,ntask_cont_to
7544         nn=ncont_sent(ii)
7545         iproc=itask_cont_to(ii)
7546         write (iout,*) nn," contacts to processor",iproc,&
7547          " of CONT_TO_COMM group"
7548         do i=1,nn
7549           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7550         enddo
7551       enddo
7552       call flush(iout)
7553       endif
7554       CorrelType=477
7555       CorrelID=fg_rank+1
7556       CorrelType1=478
7557       CorrelID1=nfgtasks+fg_rank+1
7558       ireq=0
7559 ! Receive the numbers of needed contacts from other processors
7560       do ii=1,ntask_cont_from
7561         iproc=itask_cont_from(ii)
7562         ireq=ireq+1
7563         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7564           FG_COMM,req(ireq),IERR)
7565       enddo
7566 !      write (iout,*) "IRECV ended"
7567 !      call flush(iout)
7568 ! Send the number of contacts needed by other processors
7569       do ii=1,ntask_cont_to
7570         iproc=itask_cont_to(ii)
7571         ireq=ireq+1
7572         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7573           FG_COMM,req(ireq),IERR)
7574       enddo
7575 !      write (iout,*) "ISEND ended"
7576 !      write (iout,*) "number of requests (nn)",ireq
7577       call flush(iout)
7578       if (ireq.gt.0) &
7579         call MPI_Waitall(ireq,req,status_array,ierr)
7580 !      write (iout,*)
7581 !     &  "Numbers of contacts to be received from other processors",
7582 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7583 !      call flush(iout)
7584 ! Receive contacts
7585       ireq=0
7586       do ii=1,ntask_cont_from
7587         iproc=itask_cont_from(ii)
7588         nn=ncont_recv(ii)
7589 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7590 !     &   " of CONT_TO_COMM group"
7591         call flush(iout)
7592         if (nn.gt.0) then
7593           ireq=ireq+1
7594           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7595           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7596 !          write (iout,*) "ireq,req",ireq,req(ireq)
7597         endif
7598       enddo
7599 ! Send the contacts to processors that need them
7600       do ii=1,ntask_cont_to
7601         iproc=itask_cont_to(ii)
7602         nn=ncont_sent(ii)
7603 !        write (iout,*) nn," contacts to processor",iproc,
7604 !     &   " of CONT_TO_COMM group"
7605         if (nn.gt.0) then
7606           ireq=ireq+1
7607           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7608             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7609 !          write (iout,*) "ireq,req",ireq,req(ireq)
7610 !          do i=1,nn
7611 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7612 !          enddo
7613         endif
7614       enddo
7615 !      write (iout,*) "number of requests (contacts)",ireq
7616 !      write (iout,*) "req",(req(i),i=1,4)
7617 !      call flush(iout)
7618       if (ireq.gt.0) &
7619        call MPI_Waitall(ireq,req,status_array,ierr)
7620       do iii=1,ntask_cont_from
7621         iproc=itask_cont_from(iii)
7622         nn=ncont_recv(iii)
7623         if (lprn) then
7624         write (iout,*) "Received",nn," contacts from processor",iproc,&
7625          " of CONT_FROM_COMM group"
7626         call flush(iout)
7627         do i=1,nn
7628           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7629         enddo
7630         call flush(iout)
7631         endif
7632         do i=1,nn
7633           ii=zapas_recv(1,i,iii)
7634 ! Flag the received contacts to prevent double-counting
7635           jj=-zapas_recv(2,i,iii)
7636 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7637 !          call flush(iout)
7638           nnn=num_cont_hb(ii)+1
7639           num_cont_hb(ii)=nnn
7640           jcont_hb(nnn,ii)=jj
7641           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7642           ind=3
7643           do kk=1,3
7644             ind=ind+1
7645             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7646           enddo
7647           do kk=1,2
7648             do ll=1,2
7649               ind=ind+1
7650               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7651             enddo
7652           enddo
7653           do jj=1,5
7654             do kk=1,3
7655               do ll=1,2
7656                 do mm=1,2
7657                   ind=ind+1
7658                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7659                 enddo
7660               enddo
7661             enddo
7662           enddo
7663         enddo
7664       enddo
7665       call flush(iout)
7666       if (lprn) then
7667         write (iout,'(a)') 'Contact function values after receive:'
7668         do i=nnt,nct-2
7669           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7670           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7671           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7672         enddo
7673         call flush(iout)
7674       endif
7675    30 continue
7676 #endif
7677       if (lprn) then
7678         write (iout,'(a)') 'Contact function values:'
7679         do i=nnt,nct-2
7680           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7681           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7682           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7683         enddo
7684       endif
7685       ecorr=0.0D0
7686       ecorr5=0.0d0
7687       ecorr6=0.0d0
7688
7689 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7690 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7691 ! Remove the loop below after debugging !!!
7692       do i=nnt,nct
7693         do j=1,3
7694           gradcorr(j,i)=0.0D0
7695           gradxorr(j,i)=0.0D0
7696         enddo
7697       enddo
7698 ! Calculate the dipole-dipole interaction energies
7699       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7700       do i=iatel_s,iatel_e+1
7701         num_conti=num_cont_hb(i)
7702         do jj=1,num_conti
7703           j=jcont_hb(jj,i)
7704 #ifdef MOMENT
7705           call dipole(i,j,jj)
7706 #endif
7707         enddo
7708       enddo
7709       endif
7710 ! Calculate the local-electrostatic correlation terms
7711 !                write (iout,*) "gradcorr5 in eello5 before loop"
7712 !                do iii=1,nres
7713 !                  write (iout,'(i5,3f10.5)')
7714 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7715 !                enddo
7716       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7717 !        write (iout,*) "corr loop i",i
7718         i1=i+1
7719         num_conti=num_cont_hb(i)
7720         num_conti1=num_cont_hb(i+1)
7721         do jj=1,num_conti
7722           j=jcont_hb(jj,i)
7723           jp=iabs(j)
7724           do kk=1,num_conti1
7725             j1=jcont_hb(kk,i1)
7726             jp1=iabs(j1)
7727 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7728 !     &         ' jj=',jj,' kk=',kk
7729 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7730             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7731                 .or. j.lt.0 .and. j1.gt.0) .and. &
7732                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7733 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7734 ! The system gains extra energy.
7735               n_corr=n_corr+1
7736               sqd1=dsqrt(d_cont(jj,i))
7737               sqd2=dsqrt(d_cont(kk,i1))
7738               sred_geom = sqd1*sqd2
7739               IF (sred_geom.lt.cutoff_corr) THEN
7740                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7741                   ekont,fprimcont)
7742 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7743 !d     &         ' jj=',jj,' kk=',kk
7744                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7745                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7746                 do l=1,3
7747                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7748                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7749                 enddo
7750                 n_corr1=n_corr1+1
7751 !d               write (iout,*) 'sred_geom=',sred_geom,
7752 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7753 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7754 !d               write (iout,*) "g_contij",g_contij
7755 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7756 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7757                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7758                 if (wcorr4.gt.0.0d0) &
7759                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7760                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7761                        write (iout,'(a6,4i5,0pf7.3)') &
7762                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7763 !                write (iout,*) "gradcorr5 before eello5"
7764 !                do iii=1,nres
7765 !                  write (iout,'(i5,3f10.5)')
7766 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7767 !                enddo
7768                 if (wcorr5.gt.0.0d0) &
7769                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7770 !                write (iout,*) "gradcorr5 after eello5"
7771 !                do iii=1,nres
7772 !                  write (iout,'(i5,3f10.5)')
7773 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7774 !                enddo
7775                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7776                        write (iout,'(a6,4i5,0pf7.3)') &
7777                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7778 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7779 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7780                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7781                      .or. wturn6.eq.0.0d0))then
7782 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7783                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7784                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7785                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7786 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7787 !d     &            'ecorr6=',ecorr6
7788 !d                write (iout,'(4e15.5)') sred_geom,
7789 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7790 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7791 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7792                 else if (wturn6.gt.0.0d0 &
7793                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7794 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7795                   eturn6=eturn6+eello_turn6(i,jj,kk)
7796                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7797                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7798 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7799                 endif
7800               ENDIF
7801 1111          continue
7802             endif
7803           enddo ! kk
7804         enddo ! jj
7805       enddo ! i
7806       do i=1,nres
7807         num_cont_hb(i)=num_cont_hb_old(i)
7808       enddo
7809 !                write (iout,*) "gradcorr5 in eello5"
7810 !                do iii=1,nres
7811 !                  write (iout,'(i5,3f10.5)')
7812 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7813 !                enddo
7814       return
7815       end subroutine multibody_eello
7816 !-----------------------------------------------------------------------------
7817       subroutine add_hb_contact_eello(ii,jj,itask)
7818 !      implicit real*8 (a-h,o-z)
7819 !      include "DIMENSIONS"
7820 !      include "COMMON.IOUNITS"
7821 !      include "COMMON.CONTACTS"
7822 !      integer,parameter :: maxconts=nres/4
7823       integer,parameter :: max_dim=70
7824       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7825 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7826 !      common /przechowalnia/ zapas
7827
7828       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7829       integer,dimension(4) ::itask
7830 !      write (iout,*) "itask",itask
7831       do i=1,2
7832         iproc=itask(i)
7833         if (iproc.gt.0) then
7834           do j=1,num_cont_hb(ii)
7835             jjc=jcont_hb(j,ii)
7836 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7837             if (jjc.eq.jj) then
7838               ncont_sent(iproc)=ncont_sent(iproc)+1
7839               nn=ncont_sent(iproc)
7840               zapas(1,nn,iproc)=ii
7841               zapas(2,nn,iproc)=jjc
7842               zapas(3,nn,iproc)=d_cont(j,ii)
7843               ind=3
7844               do kk=1,3
7845                 ind=ind+1
7846                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7847               enddo
7848               do kk=1,2
7849                 do ll=1,2
7850                   ind=ind+1
7851                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7852                 enddo
7853               enddo
7854               do jj=1,5
7855                 do kk=1,3
7856                   do ll=1,2
7857                     do mm=1,2
7858                       ind=ind+1
7859                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7860                     enddo
7861                   enddo
7862                 enddo
7863               enddo
7864               exit
7865             endif
7866           enddo
7867         endif
7868       enddo
7869       return
7870       end subroutine add_hb_contact_eello
7871 !-----------------------------------------------------------------------------
7872       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7873 !      implicit real*8 (a-h,o-z)
7874 !      include 'DIMENSIONS'
7875 !      include 'COMMON.IOUNITS'
7876 !      include 'COMMON.DERIV'
7877 !      include 'COMMON.INTERACT'
7878 !      include 'COMMON.CONTACTS'
7879       real(kind=8),dimension(3) :: gx,gx1
7880       logical :: lprn
7881 !el local variables
7882       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
7883       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
7884                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
7885                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
7886                    rlocshield
7887
7888       lprn=.false.
7889       eij=facont_hb(jj,i)
7890       ekl=facont_hb(kk,k)
7891       ees0pij=ees0p(jj,i)
7892       ees0pkl=ees0p(kk,k)
7893       ees0mij=ees0m(jj,i)
7894       ees0mkl=ees0m(kk,k)
7895       ekont=eij*ekl
7896       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7897 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7898 ! Following 4 lines for diagnostics.
7899 !d    ees0pkl=0.0D0
7900 !d    ees0pij=1.0D0
7901 !d    ees0mkl=0.0D0
7902 !d    ees0mij=1.0D0
7903 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7904 !     & 'Contacts ',i,j,
7905 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7906 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7907 !     & 'gradcorr_long'
7908 ! Calculate the multi-body contribution to energy.
7909 !      ecorr=ecorr+ekont*ees
7910 ! Calculate multi-body contributions to the gradient.
7911       coeffpees0pij=coeffp*ees0pij
7912       coeffmees0mij=coeffm*ees0mij
7913       coeffpees0pkl=coeffp*ees0pkl
7914       coeffmees0mkl=coeffm*ees0mkl
7915       do ll=1,3
7916 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7917         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
7918         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
7919         coeffmees0mkl*gacontm_hb1(ll,jj,i))
7920         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
7921         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
7922         coeffmees0mkl*gacontm_hb2(ll,jj,i))
7923 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7924         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
7925         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
7926         coeffmees0mij*gacontm_hb1(ll,kk,k))
7927         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
7928         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
7929         coeffmees0mij*gacontm_hb2(ll,kk,k))
7930         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
7931            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
7932            coeffmees0mkl*gacontm_hb3(ll,jj,i))
7933         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7934         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7935         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
7936            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
7937            coeffmees0mij*gacontm_hb3(ll,kk,k))
7938         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7939         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7940 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7941       enddo
7942 !      write (iout,*)
7943 !grad      do m=i+1,j-1
7944 !grad        do ll=1,3
7945 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7946 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7947 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7948 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7949 !grad        enddo
7950 !grad      enddo
7951 !grad      do m=k+1,l-1
7952 !grad        do ll=1,3
7953 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7954 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
7955 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7956 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7957 !grad        enddo
7958 !grad      enddo
7959 !      write (iout,*) "ehbcorr",ekont*ees
7960       ehbcorr=ekont*ees
7961       if (shield_mode.gt.0) then
7962        j=ees0plist(jj,i)
7963        l=ees0plist(kk,k)
7964 !C        print *,i,j,fac_shield(i),fac_shield(j),
7965 !C     &fac_shield(k),fac_shield(l)
7966         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
7967            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7968           do ilist=1,ishield_list(i)
7969            iresshield=shield_list(ilist,i)
7970            do m=1,3
7971            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7972            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7973                    rlocshield  &
7974             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7975             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7976             +rlocshield
7977            enddo
7978           enddo
7979           do ilist=1,ishield_list(j)
7980            iresshield=shield_list(ilist,j)
7981            do m=1,3
7982            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7983            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7984                    rlocshield &
7985             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7986            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7987             +rlocshield
7988            enddo
7989           enddo
7990
7991           do ilist=1,ishield_list(k)
7992            iresshield=shield_list(ilist,k)
7993            do m=1,3
7994            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7995            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7996                    rlocshield &
7997             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7998            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7999             +rlocshield
8000            enddo
8001           enddo
8002           do ilist=1,ishield_list(l)
8003            iresshield=shield_list(ilist,l)
8004            do m=1,3
8005            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8006            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8007                    rlocshield &
8008             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8009            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8010             +rlocshield
8011            enddo
8012           enddo
8013           do m=1,3
8014             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8015                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8016             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8017                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8018             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8019                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8020             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8021                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8022
8023             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8024                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8025             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8026                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8027             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8028                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8029             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8030                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8031
8032            enddo
8033       endif
8034       endif
8035       return
8036       end function ehbcorr
8037 #ifdef MOMENT
8038 !-----------------------------------------------------------------------------
8039       subroutine dipole(i,j,jj)
8040 !      implicit real*8 (a-h,o-z)
8041 !      include 'DIMENSIONS'
8042 !      include 'COMMON.IOUNITS'
8043 !      include 'COMMON.CHAIN'
8044 !      include 'COMMON.FFIELD'
8045 !      include 'COMMON.DERIV'
8046 !      include 'COMMON.INTERACT'
8047 !      include 'COMMON.CONTACTS'
8048 !      include 'COMMON.TORSION'
8049 !      include 'COMMON.VAR'
8050 !      include 'COMMON.GEO'
8051       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8052       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8053       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8054
8055       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8056       allocate(dipderx(3,5,4,maxconts,nres))
8057 !
8058
8059       iti1 = itortyp(itype(i+1,1))
8060       if (j.lt.nres-1) then
8061         itj1 = itortyp(itype(j+1,1))
8062       else
8063         itj1=ntortyp+1
8064       endif
8065       do iii=1,2
8066         dipi(iii,1)=Ub2(iii,i)
8067         dipderi(iii)=Ub2der(iii,i)
8068         dipi(iii,2)=b1(iii,iti1)
8069         dipj(iii,1)=Ub2(iii,j)
8070         dipderj(iii)=Ub2der(iii,j)
8071         dipj(iii,2)=b1(iii,itj1)
8072       enddo
8073       kkk=0
8074       do iii=1,2
8075         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8076         do jjj=1,2
8077           kkk=kkk+1
8078           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8079         enddo
8080       enddo
8081       do kkk=1,5
8082         do lll=1,3
8083           mmm=0
8084           do iii=1,2
8085             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8086               auxvec(1))
8087             do jjj=1,2
8088               mmm=mmm+1
8089               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8090             enddo
8091           enddo
8092         enddo
8093       enddo
8094       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8095       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8096       do iii=1,2
8097         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8098       enddo
8099       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8100       do iii=1,2
8101         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8102       enddo
8103       return
8104       end subroutine dipole
8105 #endif
8106 !-----------------------------------------------------------------------------
8107       subroutine calc_eello(i,j,k,l,jj,kk)
8108 !
8109 ! This subroutine computes matrices and vectors needed to calculate
8110 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8111 !
8112       use comm_kut
8113 !      implicit real*8 (a-h,o-z)
8114 !      include 'DIMENSIONS'
8115 !      include 'COMMON.IOUNITS'
8116 !      include 'COMMON.CHAIN'
8117 !      include 'COMMON.DERIV'
8118 !      include 'COMMON.INTERACT'
8119 !      include 'COMMON.CONTACTS'
8120 !      include 'COMMON.TORSION'
8121 !      include 'COMMON.VAR'
8122 !      include 'COMMON.GEO'
8123 !      include 'COMMON.FFIELD'
8124       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8125       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8126       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8127               itj1
8128 !el      logical :: lprn
8129 !el      common /kutas/ lprn
8130 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8131 !d     & ' jj=',jj,' kk=',kk
8132 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8133 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8134 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8135       do iii=1,2
8136         do jjj=1,2
8137           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8138           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8139         enddo
8140       enddo
8141       call transpose2(aa1(1,1),aa1t(1,1))
8142       call transpose2(aa2(1,1),aa2t(1,1))
8143       do kkk=1,5
8144         do lll=1,3
8145           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8146             aa1tder(1,1,lll,kkk))
8147           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8148             aa2tder(1,1,lll,kkk))
8149         enddo
8150       enddo
8151       if (l.eq.j+1) then
8152 ! parallel orientation of the two CA-CA-CA frames.
8153         if (i.gt.1) then
8154           iti=itortyp(itype(i,1))
8155         else
8156           iti=ntortyp+1
8157         endif
8158         itk1=itortyp(itype(k+1,1))
8159         itj=itortyp(itype(j,1))
8160         if (l.lt.nres-1) then
8161           itl1=itortyp(itype(l+1,1))
8162         else
8163           itl1=ntortyp+1
8164         endif
8165 ! A1 kernel(j+1) A2T
8166 !d        do iii=1,2
8167 !d          write (iout,'(3f10.5,5x,3f10.5)')
8168 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8169 !d        enddo
8170         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8171          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8172          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8173 ! Following matrices are needed only for 6-th order cumulants
8174         IF (wcorr6.gt.0.0d0) THEN
8175         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8176          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8177          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8178         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8179          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8180          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8181          ADtEAderx(1,1,1,1,1,1))
8182         lprn=.false.
8183         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8184          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8185          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8186          ADtEA1derx(1,1,1,1,1,1))
8187         ENDIF
8188 ! End 6-th order cumulants
8189 !d        lprn=.false.
8190 !d        if (lprn) then
8191 !d        write (2,*) 'In calc_eello6'
8192 !d        do iii=1,2
8193 !d          write (2,*) 'iii=',iii
8194 !d          do kkk=1,5
8195 !d            write (2,*) 'kkk=',kkk
8196 !d            do jjj=1,2
8197 !d              write (2,'(3(2f10.5),5x)')
8198 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8199 !d            enddo
8200 !d          enddo
8201 !d        enddo
8202 !d        endif
8203         call transpose2(EUgder(1,1,k),auxmat(1,1))
8204         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8205         call transpose2(EUg(1,1,k),auxmat(1,1))
8206         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8207         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8208         do iii=1,2
8209           do kkk=1,5
8210             do lll=1,3
8211               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8212                 EAEAderx(1,1,lll,kkk,iii,1))
8213             enddo
8214           enddo
8215         enddo
8216 ! A1T kernel(i+1) A2
8217         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8218          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8219          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8220 ! Following matrices are needed only for 6-th order cumulants
8221         IF (wcorr6.gt.0.0d0) THEN
8222         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8223          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8224          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8225         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8226          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8227          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8228          ADtEAderx(1,1,1,1,1,2))
8229         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8230          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8231          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8232          ADtEA1derx(1,1,1,1,1,2))
8233         ENDIF
8234 ! End 6-th order cumulants
8235         call transpose2(EUgder(1,1,l),auxmat(1,1))
8236         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8237         call transpose2(EUg(1,1,l),auxmat(1,1))
8238         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8239         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8240         do iii=1,2
8241           do kkk=1,5
8242             do lll=1,3
8243               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8244                 EAEAderx(1,1,lll,kkk,iii,2))
8245             enddo
8246           enddo
8247         enddo
8248 ! AEAb1 and AEAb2
8249 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8250 ! They are needed only when the fifth- or the sixth-order cumulants are
8251 ! indluded.
8252         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8253         call transpose2(AEA(1,1,1),auxmat(1,1))
8254         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8255         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8256         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8257         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8258         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8259         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8260         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8261         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8262         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8263         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8264         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8265         call transpose2(AEA(1,1,2),auxmat(1,1))
8266         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8267         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8268         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8269         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8270         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8271         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8272         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8273         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8274         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8275         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8276         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8277 ! Calculate the Cartesian derivatives of the vectors.
8278         do iii=1,2
8279           do kkk=1,5
8280             do lll=1,3
8281               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8282               call matvec2(auxmat(1,1),b1(1,iti),&
8283                 AEAb1derx(1,lll,kkk,iii,1,1))
8284               call matvec2(auxmat(1,1),Ub2(1,i),&
8285                 AEAb2derx(1,lll,kkk,iii,1,1))
8286               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8287                 AEAb1derx(1,lll,kkk,iii,2,1))
8288               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8289                 AEAb2derx(1,lll,kkk,iii,2,1))
8290               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8291               call matvec2(auxmat(1,1),b1(1,itj),&
8292                 AEAb1derx(1,lll,kkk,iii,1,2))
8293               call matvec2(auxmat(1,1),Ub2(1,j),&
8294                 AEAb2derx(1,lll,kkk,iii,1,2))
8295               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8296                 AEAb1derx(1,lll,kkk,iii,2,2))
8297               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8298                 AEAb2derx(1,lll,kkk,iii,2,2))
8299             enddo
8300           enddo
8301         enddo
8302         ENDIF
8303 ! End vectors
8304       else
8305 ! Antiparallel orientation of the two CA-CA-CA frames.
8306         if (i.gt.1) then
8307           iti=itortyp(itype(i,1))
8308         else
8309           iti=ntortyp+1
8310         endif
8311         itk1=itortyp(itype(k+1,1))
8312         itl=itortyp(itype(l,1))
8313         itj=itortyp(itype(j,1))
8314         if (j.lt.nres-1) then
8315           itj1=itortyp(itype(j+1,1))
8316         else
8317           itj1=ntortyp+1
8318         endif
8319 ! A2 kernel(j-1)T A1T
8320         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8321          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8322          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8323 ! Following matrices are needed only for 6-th order cumulants
8324         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8325            j.eq.i+4 .and. l.eq.i+3)) THEN
8326         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8327          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8328          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8329         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8330          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8331          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8332          ADtEAderx(1,1,1,1,1,1))
8333         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8334          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8335          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8336          ADtEA1derx(1,1,1,1,1,1))
8337         ENDIF
8338 ! End 6-th order cumulants
8339         call transpose2(EUgder(1,1,k),auxmat(1,1))
8340         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8341         call transpose2(EUg(1,1,k),auxmat(1,1))
8342         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8343         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8344         do iii=1,2
8345           do kkk=1,5
8346             do lll=1,3
8347               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8348                 EAEAderx(1,1,lll,kkk,iii,1))
8349             enddo
8350           enddo
8351         enddo
8352 ! A2T kernel(i+1)T A1
8353         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8354          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8355          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8356 ! Following matrices are needed only for 6-th order cumulants
8357         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8358            j.eq.i+4 .and. l.eq.i+3)) THEN
8359         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8360          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8361          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8362         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8363          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8364          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8365          ADtEAderx(1,1,1,1,1,2))
8366         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8367          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8368          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8369          ADtEA1derx(1,1,1,1,1,2))
8370         ENDIF
8371 ! End 6-th order cumulants
8372         call transpose2(EUgder(1,1,j),auxmat(1,1))
8373         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8374         call transpose2(EUg(1,1,j),auxmat(1,1))
8375         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8376         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8377         do iii=1,2
8378           do kkk=1,5
8379             do lll=1,3
8380               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8381                 EAEAderx(1,1,lll,kkk,iii,2))
8382             enddo
8383           enddo
8384         enddo
8385 ! AEAb1 and AEAb2
8386 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8387 ! They are needed only when the fifth- or the sixth-order cumulants are
8388 ! indluded.
8389         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8390           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8391         call transpose2(AEA(1,1,1),auxmat(1,1))
8392         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8393         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8394         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8395         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8396         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8397         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8398         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8399         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8400         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8401         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8402         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8403         call transpose2(AEA(1,1,2),auxmat(1,1))
8404         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8405         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8406         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8407         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8408         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8409         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8410         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8411         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8412         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8413         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8414         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8415 ! Calculate the Cartesian derivatives of the vectors.
8416         do iii=1,2
8417           do kkk=1,5
8418             do lll=1,3
8419               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8420               call matvec2(auxmat(1,1),b1(1,iti),&
8421                 AEAb1derx(1,lll,kkk,iii,1,1))
8422               call matvec2(auxmat(1,1),Ub2(1,i),&
8423                 AEAb2derx(1,lll,kkk,iii,1,1))
8424               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8425                 AEAb1derx(1,lll,kkk,iii,2,1))
8426               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8427                 AEAb2derx(1,lll,kkk,iii,2,1))
8428               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8429               call matvec2(auxmat(1,1),b1(1,itl),&
8430                 AEAb1derx(1,lll,kkk,iii,1,2))
8431               call matvec2(auxmat(1,1),Ub2(1,l),&
8432                 AEAb2derx(1,lll,kkk,iii,1,2))
8433               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8434                 AEAb1derx(1,lll,kkk,iii,2,2))
8435               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8436                 AEAb2derx(1,lll,kkk,iii,2,2))
8437             enddo
8438           enddo
8439         enddo
8440         ENDIF
8441 ! End vectors
8442       endif
8443       return
8444       end subroutine calc_eello
8445 !-----------------------------------------------------------------------------
8446       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8447       use comm_kut
8448       implicit none
8449       integer :: nderg
8450       logical :: transp
8451       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8452       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8453       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8454       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8455       integer :: iii,kkk,lll
8456       integer :: jjj,mmm
8457 !el      logical :: lprn
8458 !el      common /kutas/ lprn
8459       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8460       do iii=1,nderg
8461         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8462           AKAderg(1,1,iii))
8463       enddo
8464 !d      if (lprn) write (2,*) 'In kernel'
8465       do kkk=1,5
8466 !d        if (lprn) write (2,*) 'kkk=',kkk
8467         do lll=1,3
8468           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8469             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8470 !d          if (lprn) then
8471 !d            write (2,*) 'lll=',lll
8472 !d            write (2,*) 'iii=1'
8473 !d            do jjj=1,2
8474 !d              write (2,'(3(2f10.5),5x)')
8475 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8476 !d            enddo
8477 !d          endif
8478           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8479             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8480 !d          if (lprn) then
8481 !d            write (2,*) 'lll=',lll
8482 !d            write (2,*) 'iii=2'
8483 !d            do jjj=1,2
8484 !d              write (2,'(3(2f10.5),5x)')
8485 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8486 !d            enddo
8487 !d          endif
8488         enddo
8489       enddo
8490       return
8491       end subroutine kernel
8492 !-----------------------------------------------------------------------------
8493       real(kind=8) function eello4(i,j,k,l,jj,kk)
8494 !      implicit real*8 (a-h,o-z)
8495 !      include 'DIMENSIONS'
8496 !      include 'COMMON.IOUNITS'
8497 !      include 'COMMON.CHAIN'
8498 !      include 'COMMON.DERIV'
8499 !      include 'COMMON.INTERACT'
8500 !      include 'COMMON.CONTACTS'
8501 !      include 'COMMON.TORSION'
8502 !      include 'COMMON.VAR'
8503 !      include 'COMMON.GEO'
8504       real(kind=8),dimension(2,2) :: pizda
8505       real(kind=8),dimension(3) :: ggg1,ggg2
8506       real(kind=8) ::  eel4,glongij,glongkl
8507       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8508 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8509 !d        eello4=0.0d0
8510 !d        return
8511 !d      endif
8512 !d      print *,'eello4:',i,j,k,l,jj,kk
8513 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8514 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8515 !old      eij=facont_hb(jj,i)
8516 !old      ekl=facont_hb(kk,k)
8517 !old      ekont=eij*ekl
8518       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8519 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8520       gcorr_loc(k-1)=gcorr_loc(k-1) &
8521          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8522       if (l.eq.j+1) then
8523         gcorr_loc(l-1)=gcorr_loc(l-1) &
8524            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8525       else
8526         gcorr_loc(j-1)=gcorr_loc(j-1) &
8527            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8528       endif
8529       do iii=1,2
8530         do kkk=1,5
8531           do lll=1,3
8532             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8533                               -EAEAderx(2,2,lll,kkk,iii,1)
8534 !d            derx(lll,kkk,iii)=0.0d0
8535           enddo
8536         enddo
8537       enddo
8538 !d      gcorr_loc(l-1)=0.0d0
8539 !d      gcorr_loc(j-1)=0.0d0
8540 !d      gcorr_loc(k-1)=0.0d0
8541 !d      eel4=1.0d0
8542 !d      write (iout,*)'Contacts have occurred for peptide groups',
8543 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8544 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8545       if (j.lt.nres-1) then
8546         j1=j+1
8547         j2=j-1
8548       else
8549         j1=j-1
8550         j2=j-2
8551       endif
8552       if (l.lt.nres-1) then
8553         l1=l+1
8554         l2=l-1
8555       else
8556         l1=l-1
8557         l2=l-2
8558       endif
8559       do ll=1,3
8560 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8561 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8562         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8563         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8564 !grad        ghalf=0.5d0*ggg1(ll)
8565         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8566         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8567         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8568         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8569         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8570         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8571 !grad        ghalf=0.5d0*ggg2(ll)
8572         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8573         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8574         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8575         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8576         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8577         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8578       enddo
8579 !grad      do m=i+1,j-1
8580 !grad        do ll=1,3
8581 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8582 !grad        enddo
8583 !grad      enddo
8584 !grad      do m=k+1,l-1
8585 !grad        do ll=1,3
8586 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8587 !grad        enddo
8588 !grad      enddo
8589 !grad      do m=i+2,j2
8590 !grad        do ll=1,3
8591 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8592 !grad        enddo
8593 !grad      enddo
8594 !grad      do m=k+2,l2
8595 !grad        do ll=1,3
8596 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8597 !grad        enddo
8598 !grad      enddo
8599 !d      do iii=1,nres-3
8600 !d        write (2,*) iii,gcorr_loc(iii)
8601 !d      enddo
8602       eello4=ekont*eel4
8603 !d      write (2,*) 'ekont',ekont
8604 !d      write (iout,*) 'eello4',ekont*eel4
8605       return
8606       end function eello4
8607 !-----------------------------------------------------------------------------
8608       real(kind=8) function eello5(i,j,k,l,jj,kk)
8609 !      implicit real*8 (a-h,o-z)
8610 !      include 'DIMENSIONS'
8611 !      include 'COMMON.IOUNITS'
8612 !      include 'COMMON.CHAIN'
8613 !      include 'COMMON.DERIV'
8614 !      include 'COMMON.INTERACT'
8615 !      include 'COMMON.CONTACTS'
8616 !      include 'COMMON.TORSION'
8617 !      include 'COMMON.VAR'
8618 !      include 'COMMON.GEO'
8619       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8620       real(kind=8),dimension(2) :: vv
8621       real(kind=8),dimension(3) :: ggg1,ggg2
8622       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8623       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8624       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8625 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8626 !                                                                              C
8627 !                            Parallel chains                                   C
8628 !                                                                              C
8629 !          o             o                   o             o                   C
8630 !         /l\           / \             \   / \           / \   /              C
8631 !        /   \         /   \             \ /   \         /   \ /               C
8632 !       j| o |l1       | o |              o| o |         | o |o                C
8633 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8634 !      \i/   \         /   \ /             /   \         /   \                 C
8635 !       o    k1             o                                                  C
8636 !         (I)          (II)                (III)          (IV)                 C
8637 !                                                                              C
8638 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8639 !                                                                              C
8640 !                            Antiparallel chains                               C
8641 !                                                                              C
8642 !          o             o                   o             o                   C
8643 !         /j\           / \             \   / \           / \   /              C
8644 !        /   \         /   \             \ /   \         /   \ /               C
8645 !      j1| o |l        | o |              o| o |         | o |o                C
8646 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8647 !      \i/   \         /   \ /             /   \         /   \                 C
8648 !       o     k1            o                                                  C
8649 !         (I)          (II)                (III)          (IV)                 C
8650 !                                                                              C
8651 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8652 !                                                                              C
8653 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8654 !                                                                              C
8655 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8656 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8657 !d        eello5=0.0d0
8658 !d        return
8659 !d      endif
8660 !d      write (iout,*)
8661 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8662 !d     &   ' and',k,l
8663       itk=itortyp(itype(k,1))
8664       itl=itortyp(itype(l,1))
8665       itj=itortyp(itype(j,1))
8666       eello5_1=0.0d0
8667       eello5_2=0.0d0
8668       eello5_3=0.0d0
8669       eello5_4=0.0d0
8670 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8671 !d     &   eel5_3_num,eel5_4_num)
8672       do iii=1,2
8673         do kkk=1,5
8674           do lll=1,3
8675             derx(lll,kkk,iii)=0.0d0
8676           enddo
8677         enddo
8678       enddo
8679 !d      eij=facont_hb(jj,i)
8680 !d      ekl=facont_hb(kk,k)
8681 !d      ekont=eij*ekl
8682 !d      write (iout,*)'Contacts have occurred for peptide groups',
8683 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8684 !d      goto 1111
8685 ! Contribution from the graph I.
8686 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8687 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8688       call transpose2(EUg(1,1,k),auxmat(1,1))
8689       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8690       vv(1)=pizda(1,1)-pizda(2,2)
8691       vv(2)=pizda(1,2)+pizda(2,1)
8692       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8693        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8694 ! Explicit gradient in virtual-dihedral angles.
8695       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8696        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8697        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8698       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8699       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8700       vv(1)=pizda(1,1)-pizda(2,2)
8701       vv(2)=pizda(1,2)+pizda(2,1)
8702       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8703        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8704        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8705       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8706       vv(1)=pizda(1,1)-pizda(2,2)
8707       vv(2)=pizda(1,2)+pizda(2,1)
8708       if (l.eq.j+1) then
8709         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8710          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8711          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8712       else
8713         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8714          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8715          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8716       endif
8717 ! Cartesian gradient
8718       do iii=1,2
8719         do kkk=1,5
8720           do lll=1,3
8721             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8722               pizda(1,1))
8723             vv(1)=pizda(1,1)-pizda(2,2)
8724             vv(2)=pizda(1,2)+pizda(2,1)
8725             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8726              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8727              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8728           enddo
8729         enddo
8730       enddo
8731 !      goto 1112
8732 !1111  continue
8733 ! Contribution from graph II
8734       call transpose2(EE(1,1,itk),auxmat(1,1))
8735       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8736       vv(1)=pizda(1,1)+pizda(2,2)
8737       vv(2)=pizda(2,1)-pizda(1,2)
8738       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8739        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8740 ! Explicit gradient in virtual-dihedral angles.
8741       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8742        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8743       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8744       vv(1)=pizda(1,1)+pizda(2,2)
8745       vv(2)=pizda(2,1)-pizda(1,2)
8746       if (l.eq.j+1) then
8747         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8748          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8749          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8750       else
8751         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8752          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8753          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8754       endif
8755 ! Cartesian gradient
8756       do iii=1,2
8757         do kkk=1,5
8758           do lll=1,3
8759             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8760               pizda(1,1))
8761             vv(1)=pizda(1,1)+pizda(2,2)
8762             vv(2)=pizda(2,1)-pizda(1,2)
8763             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8764              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8765              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8766           enddo
8767         enddo
8768       enddo
8769 !d      goto 1112
8770 !d1111  continue
8771       if (l.eq.j+1) then
8772 !d        goto 1110
8773 ! Parallel orientation
8774 ! Contribution from graph III
8775         call transpose2(EUg(1,1,l),auxmat(1,1))
8776         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8777         vv(1)=pizda(1,1)-pizda(2,2)
8778         vv(2)=pizda(1,2)+pizda(2,1)
8779         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8780          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8781 ! Explicit gradient in virtual-dihedral angles.
8782         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8783          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8784          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8785         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8786         vv(1)=pizda(1,1)-pizda(2,2)
8787         vv(2)=pizda(1,2)+pizda(2,1)
8788         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8789          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8790          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8791         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8792         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8793         vv(1)=pizda(1,1)-pizda(2,2)
8794         vv(2)=pizda(1,2)+pizda(2,1)
8795         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8796          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8797          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8798 ! Cartesian gradient
8799         do iii=1,2
8800           do kkk=1,5
8801             do lll=1,3
8802               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8803                 pizda(1,1))
8804               vv(1)=pizda(1,1)-pizda(2,2)
8805               vv(2)=pizda(1,2)+pizda(2,1)
8806               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8807                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8808                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8809             enddo
8810           enddo
8811         enddo
8812 !d        goto 1112
8813 ! Contribution from graph IV
8814 !d1110    continue
8815         call transpose2(EE(1,1,itl),auxmat(1,1))
8816         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8817         vv(1)=pizda(1,1)+pizda(2,2)
8818         vv(2)=pizda(2,1)-pizda(1,2)
8819         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8820          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8821 ! Explicit gradient in virtual-dihedral angles.
8822         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8823          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8824         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8825         vv(1)=pizda(1,1)+pizda(2,2)
8826         vv(2)=pizda(2,1)-pizda(1,2)
8827         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8828          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8829          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8830 ! Cartesian gradient
8831         do iii=1,2
8832           do kkk=1,5
8833             do lll=1,3
8834               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8835                 pizda(1,1))
8836               vv(1)=pizda(1,1)+pizda(2,2)
8837               vv(2)=pizda(2,1)-pizda(1,2)
8838               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8839                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8840                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8841             enddo
8842           enddo
8843         enddo
8844       else
8845 ! Antiparallel orientation
8846 ! Contribution from graph III
8847 !        goto 1110
8848         call transpose2(EUg(1,1,j),auxmat(1,1))
8849         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8850         vv(1)=pizda(1,1)-pizda(2,2)
8851         vv(2)=pizda(1,2)+pizda(2,1)
8852         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8853          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8854 ! Explicit gradient in virtual-dihedral angles.
8855         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8856          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8857          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8858         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8859         vv(1)=pizda(1,1)-pizda(2,2)
8860         vv(2)=pizda(1,2)+pizda(2,1)
8861         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8862          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
8863          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8864         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8865         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8866         vv(1)=pizda(1,1)-pizda(2,2)
8867         vv(2)=pizda(1,2)+pizda(2,1)
8868         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8869          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
8870          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8871 ! Cartesian gradient
8872         do iii=1,2
8873           do kkk=1,5
8874             do lll=1,3
8875               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8876                 pizda(1,1))
8877               vv(1)=pizda(1,1)-pizda(2,2)
8878               vv(2)=pizda(1,2)+pizda(2,1)
8879               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8880                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
8881                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8882             enddo
8883           enddo
8884         enddo
8885 !d        goto 1112
8886 ! Contribution from graph IV
8887 1110    continue
8888         call transpose2(EE(1,1,itj),auxmat(1,1))
8889         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8890         vv(1)=pizda(1,1)+pizda(2,2)
8891         vv(2)=pizda(2,1)-pizda(1,2)
8892         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
8893          -0.5d0*scalar2(vv(1),Ctobr(1,j))
8894 ! Explicit gradient in virtual-dihedral angles.
8895         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8896          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8897         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8898         vv(1)=pizda(1,1)+pizda(2,2)
8899         vv(2)=pizda(2,1)-pizda(1,2)
8900         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8901          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
8902          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8903 ! Cartesian gradient
8904         do iii=1,2
8905           do kkk=1,5
8906             do lll=1,3
8907               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8908                 pizda(1,1))
8909               vv(1)=pizda(1,1)+pizda(2,2)
8910               vv(2)=pizda(2,1)-pizda(1,2)
8911               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8912                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
8913                -0.5d0*scalar2(vv(1),Ctobr(1,j))
8914             enddo
8915           enddo
8916         enddo
8917       endif
8918 1112  continue
8919       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8920 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8921 !d        write (2,*) 'ijkl',i,j,k,l
8922 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8923 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8924 !d      endif
8925 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8926 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8927 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8928 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8929       if (j.lt.nres-1) then
8930         j1=j+1
8931         j2=j-1
8932       else
8933         j1=j-1
8934         j2=j-2
8935       endif
8936       if (l.lt.nres-1) then
8937         l1=l+1
8938         l2=l-1
8939       else
8940         l1=l-1
8941         l2=l-2
8942       endif
8943 !d      eij=1.0d0
8944 !d      ekl=1.0d0
8945 !d      ekont=1.0d0
8946 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8947 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
8948 !        summed up outside the subrouine as for the other subroutines
8949 !        handling long-range interactions. The old code is commented out
8950 !        with "cgrad" to keep track of changes.
8951       do ll=1,3
8952 !grad        ggg1(ll)=eel5*g_contij(ll,1)
8953 !grad        ggg2(ll)=eel5*g_contij(ll,2)
8954         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8955         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8956 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8957 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8958 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8959 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8960 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8961 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8962 !     &   gradcorr5ij,
8963 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8964 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8965 !grad        ghalf=0.5d0*ggg1(ll)
8966 !d        ghalf=0.0d0
8967         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8968         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8969         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8970         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8971         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8972         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8973 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8974 !grad        ghalf=0.5d0*ggg2(ll)
8975         ghalf=0.0d0
8976         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8977         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8978         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8979         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8980         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8981         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8982       enddo
8983 !d      goto 1112
8984 !grad      do m=i+1,j-1
8985 !grad        do ll=1,3
8986 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8987 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8988 !grad        enddo
8989 !grad      enddo
8990 !grad      do m=k+1,l-1
8991 !grad        do ll=1,3
8992 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8993 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8994 !grad        enddo
8995 !grad      enddo
8996 !1112  continue
8997 !grad      do m=i+2,j2
8998 !grad        do ll=1,3
8999 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9000 !grad        enddo
9001 !grad      enddo
9002 !grad      do m=k+2,l2
9003 !grad        do ll=1,3
9004 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9005 !grad        enddo
9006 !grad      enddo
9007 !d      do iii=1,nres-3
9008 !d        write (2,*) iii,g_corr5_loc(iii)
9009 !d      enddo
9010       eello5=ekont*eel5
9011 !d      write (2,*) 'ekont',ekont
9012 !d      write (iout,*) 'eello5',ekont*eel5
9013       return
9014       end function eello5
9015 !-----------------------------------------------------------------------------
9016       real(kind=8) function eello6(i,j,k,l,jj,kk)
9017 !      implicit real*8 (a-h,o-z)
9018 !      include 'DIMENSIONS'
9019 !      include 'COMMON.IOUNITS'
9020 !      include 'COMMON.CHAIN'
9021 !      include 'COMMON.DERIV'
9022 !      include 'COMMON.INTERACT'
9023 !      include 'COMMON.CONTACTS'
9024 !      include 'COMMON.TORSION'
9025 !      include 'COMMON.VAR'
9026 !      include 'COMMON.GEO'
9027 !      include 'COMMON.FFIELD'
9028       real(kind=8),dimension(3) :: ggg1,ggg2
9029       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9030                    eello6_6,eel6
9031       real(kind=8) :: gradcorr6ij,gradcorr6kl
9032       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9033 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9034 !d        eello6=0.0d0
9035 !d        return
9036 !d      endif
9037 !d      write (iout,*)
9038 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9039 !d     &   ' and',k,l
9040       eello6_1=0.0d0
9041       eello6_2=0.0d0
9042       eello6_3=0.0d0
9043       eello6_4=0.0d0
9044       eello6_5=0.0d0
9045       eello6_6=0.0d0
9046 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9047 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9048       do iii=1,2
9049         do kkk=1,5
9050           do lll=1,3
9051             derx(lll,kkk,iii)=0.0d0
9052           enddo
9053         enddo
9054       enddo
9055 !d      eij=facont_hb(jj,i)
9056 !d      ekl=facont_hb(kk,k)
9057 !d      ekont=eij*ekl
9058 !d      eij=1.0d0
9059 !d      ekl=1.0d0
9060 !d      ekont=1.0d0
9061       if (l.eq.j+1) then
9062         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9063         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9064         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9065         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9066         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9067         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9068       else
9069         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9070         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9071         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9072         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9073         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9074           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9075         else
9076           eello6_5=0.0d0
9077         endif
9078         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9079       endif
9080 ! If turn contributions are considered, they will be handled separately.
9081       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9082 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9083 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9084 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9085 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9086 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9087 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9088 !d      goto 1112
9089       if (j.lt.nres-1) then
9090         j1=j+1
9091         j2=j-1
9092       else
9093         j1=j-1
9094         j2=j-2
9095       endif
9096       if (l.lt.nres-1) then
9097         l1=l+1
9098         l2=l-1
9099       else
9100         l1=l-1
9101         l2=l-2
9102       endif
9103       do ll=1,3
9104 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9105 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9106 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9107 !grad        ghalf=0.5d0*ggg1(ll)
9108 !d        ghalf=0.0d0
9109         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9110         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9111         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9112         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9113         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9114         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9115         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9116         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9117 !grad        ghalf=0.5d0*ggg2(ll)
9118 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9119 !d        ghalf=0.0d0
9120         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9121         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9122         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9123         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9124         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9125         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9126       enddo
9127 !d      goto 1112
9128 !grad      do m=i+1,j-1
9129 !grad        do ll=1,3
9130 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9131 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9132 !grad        enddo
9133 !grad      enddo
9134 !grad      do m=k+1,l-1
9135 !grad        do ll=1,3
9136 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9137 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9138 !grad        enddo
9139 !grad      enddo
9140 !grad1112  continue
9141 !grad      do m=i+2,j2
9142 !grad        do ll=1,3
9143 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9144 !grad        enddo
9145 !grad      enddo
9146 !grad      do m=k+2,l2
9147 !grad        do ll=1,3
9148 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9149 !grad        enddo
9150 !grad      enddo
9151 !d      do iii=1,nres-3
9152 !d        write (2,*) iii,g_corr6_loc(iii)
9153 !d      enddo
9154       eello6=ekont*eel6
9155 !d      write (2,*) 'ekont',ekont
9156 !d      write (iout,*) 'eello6',ekont*eel6
9157       return
9158       end function eello6
9159 !-----------------------------------------------------------------------------
9160       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9161       use comm_kut
9162 !      implicit real*8 (a-h,o-z)
9163 !      include 'DIMENSIONS'
9164 !      include 'COMMON.IOUNITS'
9165 !      include 'COMMON.CHAIN'
9166 !      include 'COMMON.DERIV'
9167 !      include 'COMMON.INTERACT'
9168 !      include 'COMMON.CONTACTS'
9169 !      include 'COMMON.TORSION'
9170 !      include 'COMMON.VAR'
9171 !      include 'COMMON.GEO'
9172       real(kind=8),dimension(2) :: vv,vv1
9173       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9174       logical :: swap
9175 !el      logical :: lprn
9176 !el      common /kutas/ lprn
9177       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9178       real(kind=8) :: s1,s2,s3,s4,s5
9179 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9180 !                                                                              C
9181 !      Parallel       Antiparallel                                             C
9182 !                                                                              C
9183 !          o             o                                                     C
9184 !         /l\           /j\                                                    C
9185 !        /   \         /   \                                                   C
9186 !       /| o |         | o |\                                                  C
9187 !     \ j|/k\|  /   \  |/k\|l /                                                C
9188 !      \ /   \ /     \ /   \ /                                                 C
9189 !       o     o       o     o                                                  C
9190 !       i             i                                                        C
9191 !                                                                              C
9192 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9193       itk=itortyp(itype(k,1))
9194       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9195       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9196       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9197       call transpose2(EUgC(1,1,k),auxmat(1,1))
9198       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9199       vv1(1)=pizda1(1,1)-pizda1(2,2)
9200       vv1(2)=pizda1(1,2)+pizda1(2,1)
9201       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9202       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9203       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9204       s5=scalar2(vv(1),Dtobr2(1,i))
9205 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9206       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9207       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9208        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9209        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9210        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9211        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9212        +scalar2(vv(1),Dtobr2der(1,i)))
9213       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9214       vv1(1)=pizda1(1,1)-pizda1(2,2)
9215       vv1(2)=pizda1(1,2)+pizda1(2,1)
9216       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9217       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9218       if (l.eq.j+1) then
9219         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9220        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9221        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9222        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9223        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9224       else
9225         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9226        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9227        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9228        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9229        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9230       endif
9231       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9232       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9233       vv1(1)=pizda1(1,1)-pizda1(2,2)
9234       vv1(2)=pizda1(1,2)+pizda1(2,1)
9235       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9236        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9237        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9238        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9239       do iii=1,2
9240         if (swap) then
9241           ind=3-iii
9242         else
9243           ind=iii
9244         endif
9245         do kkk=1,5
9246           do lll=1,3
9247             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9248             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9249             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9250             call transpose2(EUgC(1,1,k),auxmat(1,1))
9251             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9252               pizda1(1,1))
9253             vv1(1)=pizda1(1,1)-pizda1(2,2)
9254             vv1(2)=pizda1(1,2)+pizda1(2,1)
9255             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9256             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9257              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9258             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9259              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9260             s5=scalar2(vv(1),Dtobr2(1,i))
9261             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9262           enddo
9263         enddo
9264       enddo
9265       return
9266       end function eello6_graph1
9267 !-----------------------------------------------------------------------------
9268       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9269       use comm_kut
9270 !      implicit real*8 (a-h,o-z)
9271 !      include 'DIMENSIONS'
9272 !      include 'COMMON.IOUNITS'
9273 !      include 'COMMON.CHAIN'
9274 !      include 'COMMON.DERIV'
9275 !      include 'COMMON.INTERACT'
9276 !      include 'COMMON.CONTACTS'
9277 !      include 'COMMON.TORSION'
9278 !      include 'COMMON.VAR'
9279 !      include 'COMMON.GEO'
9280       logical :: swap
9281       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9282       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9283 !el      logical :: lprn
9284 !el      common /kutas/ lprn
9285       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9286       real(kind=8) :: s2,s3,s4
9287 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9288 !                                                                              C
9289 !      Parallel       Antiparallel                                             C
9290 !                                                                              C
9291 !          o             o                                                     C
9292 !     \   /l\           /j\   /                                                C
9293 !      \ /   \         /   \ /                                                 C
9294 !       o| o |         | o |o                                                  C
9295 !     \ j|/k\|      \  |/k\|l                                                  C
9296 !      \ /   \       \ /   \                                                   C
9297 !       o             o                                                        C
9298 !       i             i                                                        C
9299 !                                                                              C
9300 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9301 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9302 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9303 !           but not in a cluster cumulant
9304 #ifdef MOMENT
9305       s1=dip(1,jj,i)*dip(1,kk,k)
9306 #endif
9307       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9308       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9309       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9310       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9311       call transpose2(EUg(1,1,k),auxmat(1,1))
9312       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9313       vv(1)=pizda(1,1)-pizda(2,2)
9314       vv(2)=pizda(1,2)+pizda(2,1)
9315       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9316 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9317 #ifdef MOMENT
9318       eello6_graph2=-(s1+s2+s3+s4)
9319 #else
9320       eello6_graph2=-(s2+s3+s4)
9321 #endif
9322 !      eello6_graph2=-s3
9323 ! Derivatives in gamma(i-1)
9324       if (i.gt.1) then
9325 #ifdef MOMENT
9326         s1=dipderg(1,jj,i)*dip(1,kk,k)
9327 #endif
9328         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9329         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9330         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9331         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9332 #ifdef MOMENT
9333         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9334 #else
9335         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9336 #endif
9337 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9338       endif
9339 ! Derivatives in gamma(k-1)
9340 #ifdef MOMENT
9341       s1=dip(1,jj,i)*dipderg(1,kk,k)
9342 #endif
9343       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9344       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9345       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9346       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9347       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9348       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9349       vv(1)=pizda(1,1)-pizda(2,2)
9350       vv(2)=pizda(1,2)+pizda(2,1)
9351       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9352 #ifdef MOMENT
9353       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9354 #else
9355       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9356 #endif
9357 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9358 ! Derivatives in gamma(j-1) or gamma(l-1)
9359       if (j.gt.1) then
9360 #ifdef MOMENT
9361         s1=dipderg(3,jj,i)*dip(1,kk,k)
9362 #endif
9363         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9364         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9365         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9366         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9367         vv(1)=pizda(1,1)-pizda(2,2)
9368         vv(2)=pizda(1,2)+pizda(2,1)
9369         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9370 #ifdef MOMENT
9371         if (swap) then
9372           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9373         else
9374           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9375         endif
9376 #endif
9377         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9378 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9379       endif
9380 ! Derivatives in gamma(l-1) or gamma(j-1)
9381       if (l.gt.1) then
9382 #ifdef MOMENT
9383         s1=dip(1,jj,i)*dipderg(3,kk,k)
9384 #endif
9385         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9386         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9387         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9388         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9389         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9390         vv(1)=pizda(1,1)-pizda(2,2)
9391         vv(2)=pizda(1,2)+pizda(2,1)
9392         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9393 #ifdef MOMENT
9394         if (swap) then
9395           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9396         else
9397           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9398         endif
9399 #endif
9400         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9401 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9402       endif
9403 ! Cartesian derivatives.
9404       if (lprn) then
9405         write (2,*) 'In eello6_graph2'
9406         do iii=1,2
9407           write (2,*) 'iii=',iii
9408           do kkk=1,5
9409             write (2,*) 'kkk=',kkk
9410             do jjj=1,2
9411               write (2,'(3(2f10.5),5x)') &
9412               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9413             enddo
9414           enddo
9415         enddo
9416       endif
9417       do iii=1,2
9418         do kkk=1,5
9419           do lll=1,3
9420 #ifdef MOMENT
9421             if (iii.eq.1) then
9422               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9423             else
9424               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9425             endif
9426 #endif
9427             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9428               auxvec(1))
9429             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9430             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9431               auxvec(1))
9432             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9433             call transpose2(EUg(1,1,k),auxmat(1,1))
9434             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9435               pizda(1,1))
9436             vv(1)=pizda(1,1)-pizda(2,2)
9437             vv(2)=pizda(1,2)+pizda(2,1)
9438             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9439 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9440 #ifdef MOMENT
9441             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9442 #else
9443             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9444 #endif
9445             if (swap) then
9446               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9447             else
9448               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9449             endif
9450           enddo
9451         enddo
9452       enddo
9453       return
9454       end function eello6_graph2
9455 !-----------------------------------------------------------------------------
9456       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9457 !      implicit real*8 (a-h,o-z)
9458 !      include 'DIMENSIONS'
9459 !      include 'COMMON.IOUNITS'
9460 !      include 'COMMON.CHAIN'
9461 !      include 'COMMON.DERIV'
9462 !      include 'COMMON.INTERACT'
9463 !      include 'COMMON.CONTACTS'
9464 !      include 'COMMON.TORSION'
9465 !      include 'COMMON.VAR'
9466 !      include 'COMMON.GEO'
9467       real(kind=8),dimension(2) :: vv,auxvec
9468       real(kind=8),dimension(2,2) :: pizda,auxmat
9469       logical :: swap
9470       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9471       real(kind=8) :: s1,s2,s3,s4
9472 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9473 !                                                                              C
9474 !      Parallel       Antiparallel                                             C
9475 !                                                                              C
9476 !          o             o                                                     C
9477 !         /l\   /   \   /j\                                                    C
9478 !        /   \ /     \ /   \                                                   C
9479 !       /| o |o       o| o |\                                                  C
9480 !       j|/k\|  /      |/k\|l /                                                C
9481 !        /   \ /       /   \ /                                                 C
9482 !       /     o       /     o                                                  C
9483 !       i             i                                                        C
9484 !                                                                              C
9485 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9486 !
9487 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9488 !           energy moment and not to the cluster cumulant.
9489       iti=itortyp(itype(i,1))
9490       if (j.lt.nres-1) then
9491         itj1=itortyp(itype(j+1,1))
9492       else
9493         itj1=ntortyp+1
9494       endif
9495       itk=itortyp(itype(k,1))
9496       itk1=itortyp(itype(k+1,1))
9497       if (l.lt.nres-1) then
9498         itl1=itortyp(itype(l+1,1))
9499       else
9500         itl1=ntortyp+1
9501       endif
9502 #ifdef MOMENT
9503       s1=dip(4,jj,i)*dip(4,kk,k)
9504 #endif
9505       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9506       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9507       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9508       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9509       call transpose2(EE(1,1,itk),auxmat(1,1))
9510       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9511       vv(1)=pizda(1,1)+pizda(2,2)
9512       vv(2)=pizda(2,1)-pizda(1,2)
9513       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9514 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9515 !d     & "sum",-(s2+s3+s4)
9516 #ifdef MOMENT
9517       eello6_graph3=-(s1+s2+s3+s4)
9518 #else
9519       eello6_graph3=-(s2+s3+s4)
9520 #endif
9521 !      eello6_graph3=-s4
9522 ! Derivatives in gamma(k-1)
9523       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9524       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9525       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9526       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9527 ! Derivatives in gamma(l-1)
9528       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9529       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9530       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9531       vv(1)=pizda(1,1)+pizda(2,2)
9532       vv(2)=pizda(2,1)-pizda(1,2)
9533       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9534       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9535 ! Cartesian derivatives.
9536       do iii=1,2
9537         do kkk=1,5
9538           do lll=1,3
9539 #ifdef MOMENT
9540             if (iii.eq.1) then
9541               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9542             else
9543               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9544             endif
9545 #endif
9546             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9547               auxvec(1))
9548             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9549             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9550               auxvec(1))
9551             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9552             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9553               pizda(1,1))
9554             vv(1)=pizda(1,1)+pizda(2,2)
9555             vv(2)=pizda(2,1)-pizda(1,2)
9556             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9557 #ifdef MOMENT
9558             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9559 #else
9560             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9561 #endif
9562             if (swap) then
9563               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9564             else
9565               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9566             endif
9567 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9568           enddo
9569         enddo
9570       enddo
9571       return
9572       end function eello6_graph3
9573 !-----------------------------------------------------------------------------
9574       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9575 !      implicit real*8 (a-h,o-z)
9576 !      include 'DIMENSIONS'
9577 !      include 'COMMON.IOUNITS'
9578 !      include 'COMMON.CHAIN'
9579 !      include 'COMMON.DERIV'
9580 !      include 'COMMON.INTERACT'
9581 !      include 'COMMON.CONTACTS'
9582 !      include 'COMMON.TORSION'
9583 !      include 'COMMON.VAR'
9584 !      include 'COMMON.GEO'
9585 !      include 'COMMON.FFIELD'
9586       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9587       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9588       logical :: swap
9589       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9590               iii,kkk,lll
9591       real(kind=8) :: s1,s2,s3,s4
9592 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9593 !                                                                              C
9594 !      Parallel       Antiparallel                                             C
9595 !                                                                              C
9596 !          o             o                                                     C
9597 !         /l\   /   \   /j\                                                    C
9598 !        /   \ /     \ /   \                                                   C
9599 !       /| o |o       o| o |\                                                  C
9600 !     \ j|/k\|      \  |/k\|l                                                  C
9601 !      \ /   \       \ /   \                                                   C
9602 !       o     \       o     \                                                  C
9603 !       i             i                                                        C
9604 !                                                                              C
9605 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9606 !
9607 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9608 !           energy moment and not to the cluster cumulant.
9609 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9610       iti=itortyp(itype(i,1))
9611       itj=itortyp(itype(j,1))
9612       if (j.lt.nres-1) then
9613         itj1=itortyp(itype(j+1,1))
9614       else
9615         itj1=ntortyp+1
9616       endif
9617       itk=itortyp(itype(k,1))
9618       if (k.lt.nres-1) then
9619         itk1=itortyp(itype(k+1,1))
9620       else
9621         itk1=ntortyp+1
9622       endif
9623       itl=itortyp(itype(l,1))
9624       if (l.lt.nres-1) then
9625         itl1=itortyp(itype(l+1,1))
9626       else
9627         itl1=ntortyp+1
9628       endif
9629 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9630 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9631 !d     & ' itl',itl,' itl1',itl1
9632 #ifdef MOMENT
9633       if (imat.eq.1) then
9634         s1=dip(3,jj,i)*dip(3,kk,k)
9635       else
9636         s1=dip(2,jj,j)*dip(2,kk,l)
9637       endif
9638 #endif
9639       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9640       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9641       if (j.eq.l+1) then
9642         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9643         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9644       else
9645         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9646         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9647       endif
9648       call transpose2(EUg(1,1,k),auxmat(1,1))
9649       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9650       vv(1)=pizda(1,1)-pizda(2,2)
9651       vv(2)=pizda(2,1)+pizda(1,2)
9652       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9653 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9654 #ifdef MOMENT
9655       eello6_graph4=-(s1+s2+s3+s4)
9656 #else
9657       eello6_graph4=-(s2+s3+s4)
9658 #endif
9659 ! Derivatives in gamma(i-1)
9660       if (i.gt.1) then
9661 #ifdef MOMENT
9662         if (imat.eq.1) then
9663           s1=dipderg(2,jj,i)*dip(3,kk,k)
9664         else
9665           s1=dipderg(4,jj,j)*dip(2,kk,l)
9666         endif
9667 #endif
9668         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9669         if (j.eq.l+1) then
9670           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9671           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9672         else
9673           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9674           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9675         endif
9676         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9677         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9678 !d          write (2,*) 'turn6 derivatives'
9679 #ifdef MOMENT
9680           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9681 #else
9682           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9683 #endif
9684         else
9685 #ifdef MOMENT
9686           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9687 #else
9688           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9689 #endif
9690         endif
9691       endif
9692 ! Derivatives in gamma(k-1)
9693 #ifdef MOMENT
9694       if (imat.eq.1) then
9695         s1=dip(3,jj,i)*dipderg(2,kk,k)
9696       else
9697         s1=dip(2,jj,j)*dipderg(4,kk,l)
9698       endif
9699 #endif
9700       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9701       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9702       if (j.eq.l+1) then
9703         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9704         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9705       else
9706         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9707         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9708       endif
9709       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9710       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9711       vv(1)=pizda(1,1)-pizda(2,2)
9712       vv(2)=pizda(2,1)+pizda(1,2)
9713       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9714       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9715 #ifdef MOMENT
9716         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9717 #else
9718         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9719 #endif
9720       else
9721 #ifdef MOMENT
9722         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9723 #else
9724         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9725 #endif
9726       endif
9727 ! Derivatives in gamma(j-1) or gamma(l-1)
9728       if (l.eq.j+1 .and. l.gt.1) then
9729         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9730         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9731         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9732         vv(1)=pizda(1,1)-pizda(2,2)
9733         vv(2)=pizda(2,1)+pizda(1,2)
9734         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9735         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9736       else if (j.gt.1) then
9737         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9738         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9739         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9740         vv(1)=pizda(1,1)-pizda(2,2)
9741         vv(2)=pizda(2,1)+pizda(1,2)
9742         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9743         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9744           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9745         else
9746           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9747         endif
9748       endif
9749 ! Cartesian derivatives.
9750       do iii=1,2
9751         do kkk=1,5
9752           do lll=1,3
9753 #ifdef MOMENT
9754             if (iii.eq.1) then
9755               if (imat.eq.1) then
9756                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9757               else
9758                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9759               endif
9760             else
9761               if (imat.eq.1) then
9762                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9763               else
9764                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9765               endif
9766             endif
9767 #endif
9768             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9769               auxvec(1))
9770             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9771             if (j.eq.l+1) then
9772               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9773                 b1(1,itj1),auxvec(1))
9774               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9775             else
9776               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9777                 b1(1,itl1),auxvec(1))
9778               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9779             endif
9780             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9781               pizda(1,1))
9782             vv(1)=pizda(1,1)-pizda(2,2)
9783             vv(2)=pizda(2,1)+pizda(1,2)
9784             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9785             if (swap) then
9786               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9787 #ifdef MOMENT
9788                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9789                    -(s1+s2+s4)
9790 #else
9791                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9792                    -(s2+s4)
9793 #endif
9794                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9795               else
9796 #ifdef MOMENT
9797                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9798 #else
9799                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9800 #endif
9801                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9802               endif
9803             else
9804 #ifdef MOMENT
9805               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9806 #else
9807               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9808 #endif
9809               if (l.eq.j+1) then
9810                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9811               else
9812                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9813               endif
9814             endif
9815           enddo
9816         enddo
9817       enddo
9818       return
9819       end function eello6_graph4
9820 !-----------------------------------------------------------------------------
9821       real(kind=8) function eello_turn6(i,jj,kk)
9822 !      implicit real*8 (a-h,o-z)
9823 !      include 'DIMENSIONS'
9824 !      include 'COMMON.IOUNITS'
9825 !      include 'COMMON.CHAIN'
9826 !      include 'COMMON.DERIV'
9827 !      include 'COMMON.INTERACT'
9828 !      include 'COMMON.CONTACTS'
9829 !      include 'COMMON.TORSION'
9830 !      include 'COMMON.VAR'
9831 !      include 'COMMON.GEO'
9832       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9833       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9834       real(kind=8),dimension(3) :: ggg1,ggg2
9835       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9836       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9837 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9838 !           the respective energy moment and not to the cluster cumulant.
9839 !el local variables
9840       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9841       integer :: j1,j2,l1,l2,ll
9842       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9843       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9844       s1=0.0d0
9845       s8=0.0d0
9846       s13=0.0d0
9847 !
9848       eello_turn6=0.0d0
9849       j=i+4
9850       k=i+1
9851       l=i+3
9852       iti=itortyp(itype(i,1))
9853       itk=itortyp(itype(k,1))
9854       itk1=itortyp(itype(k+1,1))
9855       itl=itortyp(itype(l,1))
9856       itj=itortyp(itype(j,1))
9857 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9858 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
9859 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9860 !d        eello6=0.0d0
9861 !d        return
9862 !d      endif
9863 !d      write (iout,*)
9864 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9865 !d     &   ' and',k,l
9866 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
9867       do iii=1,2
9868         do kkk=1,5
9869           do lll=1,3
9870             derx_turn(lll,kkk,iii)=0.0d0
9871           enddo
9872         enddo
9873       enddo
9874 !d      eij=1.0d0
9875 !d      ekl=1.0d0
9876 !d      ekont=1.0d0
9877       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9878 !d      eello6_5=0.0d0
9879 !d      write (2,*) 'eello6_5',eello6_5
9880 #ifdef MOMENT
9881       call transpose2(AEA(1,1,1),auxmat(1,1))
9882       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9883       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9884       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9885 #endif
9886       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9887       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9888       s2 = scalar2(b1(1,itk),vtemp1(1))
9889 #ifdef MOMENT
9890       call transpose2(AEA(1,1,2),atemp(1,1))
9891       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9892       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9893       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9894 #endif
9895       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9896       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9897       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9898 #ifdef MOMENT
9899       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9900       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9901       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9902       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9903       ss13 = scalar2(b1(1,itk),vtemp4(1))
9904       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9905 #endif
9906 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9907 !      s1=0.0d0
9908 !      s2=0.0d0
9909 !      s8=0.0d0
9910 !      s12=0.0d0
9911 !      s13=0.0d0
9912       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9913 ! Derivatives in gamma(i+2)
9914       s1d =0.0d0
9915       s8d =0.0d0
9916 #ifdef MOMENT
9917       call transpose2(AEA(1,1,1),auxmatd(1,1))
9918       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9919       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9920       call transpose2(AEAderg(1,1,2),atempd(1,1))
9921       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9922       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9923 #endif
9924       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9925       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9926       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9927 !      s1d=0.0d0
9928 !      s2d=0.0d0
9929 !      s8d=0.0d0
9930 !      s12d=0.0d0
9931 !      s13d=0.0d0
9932       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9933 ! Derivatives in gamma(i+3)
9934 #ifdef MOMENT
9935       call transpose2(AEA(1,1,1),auxmatd(1,1))
9936       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9937       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9938       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9939 #endif
9940       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9941       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9942       s2d = scalar2(b1(1,itk),vtemp1d(1))
9943 #ifdef MOMENT
9944       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9945       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9946 #endif
9947       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9948 #ifdef MOMENT
9949       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9950       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9951       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9952 #endif
9953 !      s1d=0.0d0
9954 !      s2d=0.0d0
9955 !      s8d=0.0d0
9956 !      s12d=0.0d0
9957 !      s13d=0.0d0
9958 #ifdef MOMENT
9959       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9960                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9961 #else
9962       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9963                     -0.5d0*ekont*(s2d+s12d)
9964 #endif
9965 ! Derivatives in gamma(i+4)
9966       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9967       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9968       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9969 #ifdef MOMENT
9970       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9971       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9972       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9973 #endif
9974 !      s1d=0.0d0
9975 !      s2d=0.0d0
9976 !      s8d=0.0d0
9977 !      s12d=0.0d0
9978 !      s13d=0.0d0
9979 #ifdef MOMENT
9980       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9981 #else
9982       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9983 #endif
9984 ! Derivatives in gamma(i+5)
9985 #ifdef MOMENT
9986       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9987       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9988       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9989 #endif
9990       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9991       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9992       s2d = scalar2(b1(1,itk),vtemp1d(1))
9993 #ifdef MOMENT
9994       call transpose2(AEA(1,1,2),atempd(1,1))
9995       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9996       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9997 #endif
9998       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9999       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10000 #ifdef MOMENT
10001       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10002       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10003       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10004 #endif
10005 !      s1d=0.0d0
10006 !      s2d=0.0d0
10007 !      s8d=0.0d0
10008 !      s12d=0.0d0
10009 !      s13d=0.0d0
10010 #ifdef MOMENT
10011       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10012                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10013 #else
10014       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10015                     -0.5d0*ekont*(s2d+s12d)
10016 #endif
10017 ! Cartesian derivatives
10018       do iii=1,2
10019         do kkk=1,5
10020           do lll=1,3
10021 #ifdef MOMENT
10022             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10023             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10024             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10025 #endif
10026             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10027             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10028                 vtemp1d(1))
10029             s2d = scalar2(b1(1,itk),vtemp1d(1))
10030 #ifdef MOMENT
10031             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10032             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10033             s8d = -(atempd(1,1)+atempd(2,2))* &
10034                  scalar2(cc(1,1,itl),vtemp2(1))
10035 #endif
10036             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10037                  auxmatd(1,1))
10038             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10039             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10040 !      s1d=0.0d0
10041 !      s2d=0.0d0
10042 !      s8d=0.0d0
10043 !      s12d=0.0d0
10044 !      s13d=0.0d0
10045 #ifdef MOMENT
10046             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10047               - 0.5d0*(s1d+s2d)
10048 #else
10049             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10050               - 0.5d0*s2d
10051 #endif
10052 #ifdef MOMENT
10053             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10054               - 0.5d0*(s8d+s12d)
10055 #else
10056             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10057               - 0.5d0*s12d
10058 #endif
10059           enddo
10060         enddo
10061       enddo
10062 #ifdef MOMENT
10063       do kkk=1,5
10064         do lll=1,3
10065           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10066             achuj_tempd(1,1))
10067           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10068           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10069           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10070           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10071           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10072             vtemp4d(1))
10073           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10074           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10075           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10076         enddo
10077       enddo
10078 #endif
10079 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10080 !d     &  16*eel_turn6_num
10081 !d      goto 1112
10082       if (j.lt.nres-1) then
10083         j1=j+1
10084         j2=j-1
10085       else
10086         j1=j-1
10087         j2=j-2
10088       endif
10089       if (l.lt.nres-1) then
10090         l1=l+1
10091         l2=l-1
10092       else
10093         l1=l-1
10094         l2=l-2
10095       endif
10096       do ll=1,3
10097 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10098 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10099 !grad        ghalf=0.5d0*ggg1(ll)
10100 !d        ghalf=0.0d0
10101         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10102         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10103         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10104           +ekont*derx_turn(ll,2,1)
10105         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10106         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10107           +ekont*derx_turn(ll,4,1)
10108         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10109         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10110         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10111 !grad        ghalf=0.5d0*ggg2(ll)
10112 !d        ghalf=0.0d0
10113         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10114           +ekont*derx_turn(ll,2,2)
10115         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10116         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10117           +ekont*derx_turn(ll,4,2)
10118         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10119         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10120         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10121       enddo
10122 !d      goto 1112
10123 !grad      do m=i+1,j-1
10124 !grad        do ll=1,3
10125 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10126 !grad        enddo
10127 !grad      enddo
10128 !grad      do m=k+1,l-1
10129 !grad        do ll=1,3
10130 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10131 !grad        enddo
10132 !grad      enddo
10133 !grad1112  continue
10134 !grad      do m=i+2,j2
10135 !grad        do ll=1,3
10136 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10137 !grad        enddo
10138 !grad      enddo
10139 !grad      do m=k+2,l2
10140 !grad        do ll=1,3
10141 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10142 !grad        enddo
10143 !grad      enddo
10144 !d      do iii=1,nres-3
10145 !d        write (2,*) iii,g_corr6_loc(iii)
10146 !d      enddo
10147       eello_turn6=ekont*eel_turn6
10148 !d      write (2,*) 'ekont',ekont
10149 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10150       return
10151       end function eello_turn6
10152 !-----------------------------------------------------------------------------
10153       subroutine MATVEC2(A1,V1,V2)
10154 !DIR$ INLINEALWAYS MATVEC2
10155 #ifndef OSF
10156 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10157 #endif
10158 !      implicit real*8 (a-h,o-z)
10159 !      include 'DIMENSIONS'
10160       real(kind=8),dimension(2) :: V1,V2
10161       real(kind=8),dimension(2,2) :: A1
10162       real(kind=8) :: vaux1,vaux2
10163 !      DO 1 I=1,2
10164 !        VI=0.0
10165 !        DO 3 K=1,2
10166 !    3     VI=VI+A1(I,K)*V1(K)
10167 !        Vaux(I)=VI
10168 !    1 CONTINUE
10169
10170       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10171       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10172
10173       v2(1)=vaux1
10174       v2(2)=vaux2
10175       end subroutine MATVEC2
10176 !-----------------------------------------------------------------------------
10177       subroutine MATMAT2(A1,A2,A3)
10178 #ifndef OSF
10179 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10180 #endif
10181 !      implicit real*8 (a-h,o-z)
10182 !      include 'DIMENSIONS'
10183       real(kind=8),dimension(2,2) :: A1,A2,A3
10184       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10185 !      DIMENSION AI3(2,2)
10186 !        DO  J=1,2
10187 !          A3IJ=0.0
10188 !          DO K=1,2
10189 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10190 !          enddo
10191 !          A3(I,J)=A3IJ
10192 !       enddo
10193 !      enddo
10194
10195       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10196       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10197       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10198       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10199
10200       A3(1,1)=AI3_11
10201       A3(2,1)=AI3_21
10202       A3(1,2)=AI3_12
10203       A3(2,2)=AI3_22
10204       end subroutine MATMAT2
10205 !-----------------------------------------------------------------------------
10206       real(kind=8) function scalar2(u,v)
10207 !DIR$ INLINEALWAYS scalar2
10208       implicit none
10209       real(kind=8),dimension(2) :: u,v
10210       real(kind=8) :: sc
10211       integer :: i
10212       scalar2=u(1)*v(1)+u(2)*v(2)
10213       return
10214       end function scalar2
10215 !-----------------------------------------------------------------------------
10216       subroutine transpose2(a,at)
10217 !DIR$ INLINEALWAYS transpose2
10218 #ifndef OSF
10219 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10220 #endif
10221       implicit none
10222       real(kind=8),dimension(2,2) :: a,at
10223       at(1,1)=a(1,1)
10224       at(1,2)=a(2,1)
10225       at(2,1)=a(1,2)
10226       at(2,2)=a(2,2)
10227       return
10228       end subroutine transpose2
10229 !-----------------------------------------------------------------------------
10230       subroutine transpose(n,a,at)
10231       implicit none
10232       integer :: n,i,j
10233       real(kind=8),dimension(n,n) :: a,at
10234       do i=1,n
10235         do j=1,n
10236           at(j,i)=a(i,j)
10237         enddo
10238       enddo
10239       return
10240       end subroutine transpose
10241 !-----------------------------------------------------------------------------
10242       subroutine prodmat3(a1,a2,kk,transp,prod)
10243 !DIR$ INLINEALWAYS prodmat3
10244 #ifndef OSF
10245 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10246 #endif
10247       implicit none
10248       integer :: i,j
10249       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10250       logical :: transp
10251 !rc      double precision auxmat(2,2),prod_(2,2)
10252
10253       if (transp) then
10254 !rc        call transpose2(kk(1,1),auxmat(1,1))
10255 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10256 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10257
10258            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10259        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10260            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10261        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10262            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10263        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10264            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10265        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10266
10267       else
10268 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10269 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10270
10271            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10272         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10273            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10274         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10275            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10276         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10277            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10278         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10279
10280       endif
10281 !      call transpose2(a2(1,1),a2t(1,1))
10282
10283 !rc      print *,transp
10284 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10285 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10286
10287       return
10288       end subroutine prodmat3
10289 !-----------------------------------------------------------------------------
10290 ! energy_p_new_barrier.F
10291 !-----------------------------------------------------------------------------
10292       subroutine sum_gradient
10293 !      implicit real*8 (a-h,o-z)
10294       use io_base, only: pdbout
10295 !      include 'DIMENSIONS'
10296 #ifndef ISNAN
10297       external proc_proc
10298 #ifdef WINPGI
10299 !MS$ATTRIBUTES C ::  proc_proc
10300 #endif
10301 #endif
10302 #ifdef MPI
10303       include 'mpif.h'
10304 #endif
10305       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10306                    gloc_scbuf !(3,maxres)
10307
10308       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10309 !#endif
10310 !el local variables
10311       integer :: i,j,k,ierror,ierr
10312       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10313                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10314                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10315                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10316                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10317                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10318                    gsccorr_max,gsccorrx_max,time00
10319
10320 !      include 'COMMON.SETUP'
10321 !      include 'COMMON.IOUNITS'
10322 !      include 'COMMON.FFIELD'
10323 !      include 'COMMON.DERIV'
10324 !      include 'COMMON.INTERACT'
10325 !      include 'COMMON.SBRIDGE'
10326 !      include 'COMMON.CHAIN'
10327 !      include 'COMMON.VAR'
10328 !      include 'COMMON.CONTROL'
10329 !      include 'COMMON.TIME1'
10330 !      include 'COMMON.MAXGRAD'
10331 !      include 'COMMON.SCCOR'
10332 #ifdef TIMING
10333       time01=MPI_Wtime()
10334 #endif
10335 #ifdef DEBUG
10336       write (iout,*) "sum_gradient gvdwc, gvdwx"
10337       do i=1,nres
10338         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10339          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10340       enddo
10341       call flush(iout)
10342 #endif
10343 #ifdef MPI
10344         gradbufc=0.0d0
10345         gradbufx=0.0d0
10346         gradbufc_sum=0.0d0
10347         gloc_scbuf=0.0d0
10348         glocbuf=0.0d0
10349 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10350         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10351           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10352 #endif
10353 !
10354 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10355 !            in virtual-bond-vector coordinates
10356 !
10357 #ifdef DEBUG
10358 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10359 !      do i=1,nres-1
10360 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10361 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10362 !      enddo
10363 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10364 !      do i=1,nres-1
10365 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10366 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10367 !      enddo
10368       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10369       do i=1,nres
10370         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10371          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10372          (gvdwc_scpp(j,i),j=1,3)
10373       enddo
10374       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10375       do i=1,nres
10376         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10377          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10378          (gelc_loc_long(j,i),j=1,3)
10379       enddo
10380       call flush(iout)
10381 #endif
10382 #ifdef SPLITELE
10383       do i=0,nct
10384         do j=1,3
10385           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10386                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10387                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10388                       wel_loc*gel_loc_long(j,i)+ &
10389                       wcorr*gradcorr_long(j,i)+ &
10390                       wcorr5*gradcorr5_long(j,i)+ &
10391                       wcorr6*gradcorr6_long(j,i)+ &
10392                       wturn6*gcorr6_turn_long(j,i)+ &
10393                       wstrain*ghpbc(j,i) &
10394                      +wliptran*gliptranc(j,i) &
10395                      +gradafm(j,i) &
10396                      +welec*gshieldc(j,i) &
10397                      +wcorr*gshieldc_ec(j,i) &
10398                      +wturn3*gshieldc_t3(j,i)&
10399                      +wturn4*gshieldc_t4(j,i)&
10400                      +wel_loc*gshieldc_ll(j,i)&
10401                      +wtube*gg_tube(j,i) &
10402                      +wbond_nucl*gradb_nucl(j,i)
10403         enddo
10404       enddo
10405 #else
10406       do i=0,nct
10407         do j=1,3
10408           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10409                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10410                       welec*gelc_long(j,i)+ &
10411                       wbond*gradb(j,i)+ &
10412                       wel_loc*gel_loc_long(j,i)+ &
10413                       wcorr*gradcorr_long(j,i)+ &
10414                       wcorr5*gradcorr5_long(j,i)+ &
10415                       wcorr6*gradcorr6_long(j,i)+ &
10416                       wturn6*gcorr6_turn_long(j,i)+ &
10417                       wstrain*ghpbc(j,i) &
10418                      +wliptran*gliptranc(j,i) &
10419                      +gradafm(j,i) &
10420                      +welec*gshieldc(j,i)&
10421                      +wcorr*gshieldc_ec(j,i) &
10422                      +wturn4*gshieldc_t4(j,i) &
10423                      +wel_loc*gshieldc_ll(j,i)&
10424                      +wtube*gg_tube(j,i) &
10425                      +wbond_nucl*gradb_nucl(j,i)
10426
10427         enddo
10428       enddo
10429 #endif
10430 #ifdef MPI
10431       if (nfgtasks.gt.1) then
10432       time00=MPI_Wtime()
10433 #ifdef DEBUG
10434       write (iout,*) "gradbufc before allreduce"
10435       do i=1,nres
10436         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10437       enddo
10438       call flush(iout)
10439 #endif
10440       do i=0,nres
10441         do j=1,3
10442           gradbufc_sum(j,i)=gradbufc(j,i)
10443         enddo
10444       enddo
10445 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10446 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10447 !      time_reduce=time_reduce+MPI_Wtime()-time00
10448 #ifdef DEBUG
10449 !      write (iout,*) "gradbufc_sum after allreduce"
10450 !      do i=1,nres
10451 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10452 !      enddo
10453 !      call flush(iout)
10454 #endif
10455 #ifdef TIMING
10456 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10457 #endif
10458       do i=0,nres
10459         do k=1,3
10460           gradbufc(k,i)=0.0d0
10461         enddo
10462       enddo
10463 #ifdef DEBUG
10464       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10465       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10466                         " jgrad_end  ",jgrad_end(i),&
10467                         i=igrad_start,igrad_end)
10468 #endif
10469 !
10470 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10471 ! do not parallelize this part.
10472 !
10473 !      do i=igrad_start,igrad_end
10474 !        do j=jgrad_start(i),jgrad_end(i)
10475 !          do k=1,3
10476 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10477 !          enddo
10478 !        enddo
10479 !      enddo
10480       do j=1,3
10481         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10482       enddo
10483       do i=nres-2,-1,-1
10484         do j=1,3
10485           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10486         enddo
10487       enddo
10488 #ifdef DEBUG
10489       write (iout,*) "gradbufc after summing"
10490       do i=1,nres
10491         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10492       enddo
10493       call flush(iout)
10494 #endif
10495       else
10496 #endif
10497 !el#define DEBUG
10498 #ifdef DEBUG
10499       write (iout,*) "gradbufc"
10500       do i=1,nres
10501         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10502       enddo
10503       call flush(iout)
10504 #endif
10505 !el#undef DEBUG
10506       do i=-1,nres
10507         do j=1,3
10508           gradbufc_sum(j,i)=gradbufc(j,i)
10509           gradbufc(j,i)=0.0d0
10510         enddo
10511       enddo
10512       do j=1,3
10513         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10514       enddo
10515       do i=nres-2,-1,-1
10516         do j=1,3
10517           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10518         enddo
10519       enddo
10520 !      do i=nnt,nres-1
10521 !        do k=1,3
10522 !          gradbufc(k,i)=0.0d0
10523 !        enddo
10524 !        do j=i+1,nres
10525 !          do k=1,3
10526 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10527 !          enddo
10528 !        enddo
10529 !      enddo
10530 !el#define DEBUG
10531 #ifdef DEBUG
10532       write (iout,*) "gradbufc after summing"
10533       do i=1,nres
10534         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10535       enddo
10536       call flush(iout)
10537 #endif
10538 !el#undef DEBUG
10539 #ifdef MPI
10540       endif
10541 #endif
10542       do k=1,3
10543         gradbufc(k,nres)=0.0d0
10544       enddo
10545 !el----------------
10546 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10547 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10548 !el-----------------
10549       do i=-1,nct
10550         do j=1,3
10551 #ifdef SPLITELE
10552           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10553                       wel_loc*gel_loc(j,i)+ &
10554                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10555                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10556                       wel_loc*gel_loc_long(j,i)+ &
10557                       wcorr*gradcorr_long(j,i)+ &
10558                       wcorr5*gradcorr5_long(j,i)+ &
10559                       wcorr6*gradcorr6_long(j,i)+ &
10560                       wturn6*gcorr6_turn_long(j,i))+ &
10561                       wbond*gradb(j,i)+ &
10562                       wcorr*gradcorr(j,i)+ &
10563                       wturn3*gcorr3_turn(j,i)+ &
10564                       wturn4*gcorr4_turn(j,i)+ &
10565                       wcorr5*gradcorr5(j,i)+ &
10566                       wcorr6*gradcorr6(j,i)+ &
10567                       wturn6*gcorr6_turn(j,i)+ &
10568                       wsccor*gsccorc(j,i) &
10569                      +wscloc*gscloc(j,i)  &
10570                      +wliptran*gliptranc(j,i) &
10571                      +gradafm(j,i) &
10572                      +welec*gshieldc(j,i) &
10573                      +welec*gshieldc_loc(j,i) &
10574                      +wcorr*gshieldc_ec(j,i) &
10575                      +wcorr*gshieldc_loc_ec(j,i) &
10576                      +wturn3*gshieldc_t3(j,i) &
10577                      +wturn3*gshieldc_loc_t3(j,i) &
10578                      +wturn4*gshieldc_t4(j,i) &
10579                      +wturn4*gshieldc_loc_t4(j,i) &
10580                      +wel_loc*gshieldc_ll(j,i) &
10581                      +wel_loc*gshieldc_loc_ll(j,i) &
10582                      +wtube*gg_tube(j,i) &
10583                      +wbond_nucl*gradb_nucl(j,i)
10584
10585
10586
10587 #else
10588           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10589                       wel_loc*gel_loc(j,i)+ &
10590                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10591                       welec*gelc_long(j,i)+ &
10592                       wel_loc*gel_loc_long(j,i)+ &
10593 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10594                       wcorr5*gradcorr5_long(j,i)+ &
10595                       wcorr6*gradcorr6_long(j,i)+ &
10596                       wturn6*gcorr6_turn_long(j,i))+ &
10597                       wbond*gradb(j,i)+ &
10598                       wcorr*gradcorr(j,i)+ &
10599                       wturn3*gcorr3_turn(j,i)+ &
10600                       wturn4*gcorr4_turn(j,i)+ &
10601                       wcorr5*gradcorr5(j,i)+ &
10602                       wcorr6*gradcorr6(j,i)+ &
10603                       wturn6*gcorr6_turn(j,i)+ &
10604                       wsccor*gsccorc(j,i) &
10605                      +wscloc*gscloc(j,i) &
10606                      +gradafm(j,i) &
10607                      +wliptran*gliptranc(j,i) &
10608                      +welec*gshieldc(j,i) &
10609                      +welec*gshieldc_loc(j,) &
10610                      +wcorr*gshieldc_ec(j,i) &
10611                      +wcorr*gshieldc_loc_ec(j,i) &
10612                      +wturn3*gshieldc_t3(j,i) &
10613                      +wturn3*gshieldc_loc_t3(j,i) &
10614                      +wturn4*gshieldc_t4(j,i) &
10615                      +wturn4*gshieldc_loc_t4(j,i) &
10616                      +wel_loc*gshieldc_ll(j,i) &
10617                      +wel_loc*gshieldc_loc_ll(j,i) &
10618                      +wtube*gg_tube(j,i) &
10619                      +wbond_nucl*gradb_nucl(j,i)
10620
10621
10622
10623
10624 #endif
10625           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10626                         wbond*gradbx(j,i)+ &
10627                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10628                         wsccor*gsccorx(j,i) &
10629                        +wscloc*gsclocx(j,i) &
10630                        +wliptran*gliptranx(j,i) &
10631                        +welec*gshieldx(j,i)     &
10632                        +wcorr*gshieldx_ec(j,i)  &
10633                        +wturn3*gshieldx_t3(j,i) &
10634                        +wturn4*gshieldx_t4(j,i) &
10635                        +wel_loc*gshieldx_ll(j,i)&
10636                        +wtube*gg_tube_sc(j,i)   &
10637                        +wbond_nucl*gradbx_nucl(j,i)
10638
10639
10640
10641         enddo
10642       enddo
10643 #ifdef DEBUG
10644       write (iout,*) "gloc before adding corr"
10645       do i=1,4*nres
10646         write (iout,*) i,gloc(i,icg)
10647       enddo
10648 #endif
10649       do i=1,nres-3
10650         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10651          +wcorr5*g_corr5_loc(i) &
10652          +wcorr6*g_corr6_loc(i) &
10653          +wturn4*gel_loc_turn4(i) &
10654          +wturn3*gel_loc_turn3(i) &
10655          +wturn6*gel_loc_turn6(i) &
10656          +wel_loc*gel_loc_loc(i)
10657       enddo
10658 #ifdef DEBUG
10659       write (iout,*) "gloc after adding corr"
10660       do i=1,4*nres
10661         write (iout,*) i,gloc(i,icg)
10662       enddo
10663 #endif
10664 #ifdef MPI
10665       if (nfgtasks.gt.1) then
10666         do j=1,3
10667           do i=1,nres
10668             gradbufc(j,i)=gradc(j,i,icg)
10669             gradbufx(j,i)=gradx(j,i,icg)
10670           enddo
10671         enddo
10672         do i=1,4*nres
10673           glocbuf(i)=gloc(i,icg)
10674         enddo
10675 !#define DEBUG
10676 #ifdef DEBUG
10677       write (iout,*) "gloc_sc before reduce"
10678       do i=1,nres
10679        do j=1,1
10680         write (iout,*) i,j,gloc_sc(j,i,icg)
10681        enddo
10682       enddo
10683 #endif
10684 !#undef DEBUG
10685         do i=1,nres
10686          do j=1,3
10687           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10688          enddo
10689         enddo
10690         time00=MPI_Wtime()
10691         call MPI_Barrier(FG_COMM,IERR)
10692         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10693         time00=MPI_Wtime()
10694         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10695           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10696         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
10697           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10698         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10699           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10700         time_reduce=time_reduce+MPI_Wtime()-time00
10701         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10702           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10703         time_reduce=time_reduce+MPI_Wtime()-time00
10704 !#define DEBUG
10705 #ifdef DEBUG
10706       write (iout,*) "gloc_sc after reduce"
10707       do i=1,nres
10708        do j=1,1
10709         write (iout,*) i,j,gloc_sc(j,i,icg)
10710        enddo
10711       enddo
10712 #endif
10713 !#undef DEBUG
10714 #ifdef DEBUG
10715       write (iout,*) "gloc after reduce"
10716       do i=1,4*nres
10717         write (iout,*) i,gloc(i,icg)
10718       enddo
10719 #endif
10720       endif
10721 #endif
10722       if (gnorm_check) then
10723 !
10724 ! Compute the maximum elements of the gradient
10725 !
10726       gvdwc_max=0.0d0
10727       gvdwc_scp_max=0.0d0
10728       gelc_max=0.0d0
10729       gvdwpp_max=0.0d0
10730       gradb_max=0.0d0
10731       ghpbc_max=0.0d0
10732       gradcorr_max=0.0d0
10733       gel_loc_max=0.0d0
10734       gcorr3_turn_max=0.0d0
10735       gcorr4_turn_max=0.0d0
10736       gradcorr5_max=0.0d0
10737       gradcorr6_max=0.0d0
10738       gcorr6_turn_max=0.0d0
10739       gsccorc_max=0.0d0
10740       gscloc_max=0.0d0
10741       gvdwx_max=0.0d0
10742       gradx_scp_max=0.0d0
10743       ghpbx_max=0.0d0
10744       gradxorr_max=0.0d0
10745       gsccorx_max=0.0d0
10746       gsclocx_max=0.0d0
10747       do i=1,nct
10748         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10749         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10750         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10751         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10752          gvdwc_scp_max=gvdwc_scp_norm
10753         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10754         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10755         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10756         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10757         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10758         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10759         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10760         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10761         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10762         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10763         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10764         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10765         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10766           gcorr3_turn(1,i)))
10767         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10768           gcorr3_turn_max=gcorr3_turn_norm
10769         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10770           gcorr4_turn(1,i)))
10771         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10772           gcorr4_turn_max=gcorr4_turn_norm
10773         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10774         if (gradcorr5_norm.gt.gradcorr5_max) &
10775           gradcorr5_max=gradcorr5_norm
10776         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10777         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10778         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10779           gcorr6_turn(1,i)))
10780         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10781           gcorr6_turn_max=gcorr6_turn_norm
10782         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
10783         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
10784         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
10785         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
10786         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
10787         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
10788         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
10789         if (gradx_scp_norm.gt.gradx_scp_max) &
10790           gradx_scp_max=gradx_scp_norm
10791         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
10792         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
10793         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
10794         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
10795         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
10796         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
10797         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
10798         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
10799       enddo
10800       if (gradout) then
10801 #ifdef AIX
10802         open(istat,file=statname,position="append")
10803 #else
10804         open(istat,file=statname,access="append")
10805 #endif
10806         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
10807            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
10808            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
10809            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
10810            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
10811            gsccorx_max,gsclocx_max
10812         close(istat)
10813         if (gvdwc_max.gt.1.0d4) then
10814           write (iout,*) "gvdwc gvdwx gradb gradbx"
10815           do i=nnt,nct
10816             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
10817               gradb(j,i),gradbx(j,i),j=1,3)
10818           enddo
10819           call pdbout(0.0d0,'cipiszcze',iout)
10820           call flush(iout)
10821         endif
10822       endif
10823       endif
10824 !el#define DEBUG
10825 #ifdef DEBUG
10826       write (iout,*) "gradc gradx gloc"
10827       do i=1,nres
10828         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
10829          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
10830       enddo
10831 #endif
10832 !el#undef DEBUG
10833 #ifdef TIMING
10834       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
10835 #endif
10836       return
10837       end subroutine sum_gradient
10838 !-----------------------------------------------------------------------------
10839       subroutine sc_grad
10840 !      implicit real*8 (a-h,o-z)
10841       use calc_data
10842 !      include 'DIMENSIONS'
10843 !      include 'COMMON.CHAIN'
10844 !      include 'COMMON.DERIV'
10845 !      include 'COMMON.CALC'
10846 !      include 'COMMON.IOUNITS'
10847       real(kind=8), dimension(3) :: dcosom1,dcosom2
10848 !      print *,"wchodze"
10849       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
10850       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
10851       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
10852            -2.0D0*alf12*eps3der+sigder*sigsq_om12
10853 ! diagnostics only
10854 !      eom1=0.0d0
10855 !      eom2=0.0d0
10856 !      eom12=evdwij*eps1_om12
10857 ! end diagnostics
10858 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
10859 !       " sigder",sigder
10860 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
10861 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
10862 !C      print *,sss_ele_cut,'in sc_grad'
10863       do k=1,3
10864         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
10865         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
10866       enddo
10867       do k=1,3
10868         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
10869 !C      print *,'gg',k,gg(k)
10870        enddo
10871 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
10872 !      write (iout,*) "gg",(gg(k),k=1,3)
10873       do k=1,3
10874         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
10875                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10876                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
10877                   *sss_ele_cut
10878
10879         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
10880                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10881                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
10882                   *sss_ele_cut
10883
10884 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10885 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
10886 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10887 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
10888       enddo
10889 !
10890 ! Calculate the components of the gradient in DC and X
10891 !
10892 !grad      do k=i,j-1
10893 !grad        do l=1,3
10894 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
10895 !grad        enddo
10896 !grad      enddo
10897       do l=1,3
10898         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
10899         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
10900       enddo
10901       return
10902       end subroutine sc_grad
10903 #ifdef CRYST_THETA
10904 !-----------------------------------------------------------------------------
10905       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
10906
10907       use comm_calcthet
10908 !      implicit real*8 (a-h,o-z)
10909 !      include 'DIMENSIONS'
10910 !      include 'COMMON.LOCAL'
10911 !      include 'COMMON.IOUNITS'
10912 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
10913 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10914 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
10915       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
10916       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
10917 !el      integer :: it
10918 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
10919 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10920 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
10921 !el local variables
10922
10923       delthec=thetai-thet_pred_mean
10924       delthe0=thetai-theta0i
10925 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
10926       t3 = thetai-thet_pred_mean
10927       t6 = t3**2
10928       t9 = term1
10929       t12 = t3*sigcsq
10930       t14 = t12+t6*sigsqtc
10931       t16 = 1.0d0
10932       t21 = thetai-theta0i
10933       t23 = t21**2
10934       t26 = term2
10935       t27 = t21*t26
10936       t32 = termexp
10937       t40 = t32**2
10938       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
10939        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
10940        *(-t12*t9-ak*sig0inv*t27)
10941       return
10942       end subroutine mixder
10943 #endif
10944 !-----------------------------------------------------------------------------
10945 ! cartder.F
10946 !-----------------------------------------------------------------------------
10947       subroutine cartder
10948 !-----------------------------------------------------------------------------
10949 ! This subroutine calculates the derivatives of the consecutive virtual
10950 ! bond vectors and the SC vectors in the virtual-bond angles theta and
10951 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
10952 ! in the angles alpha and omega, describing the location of a side chain
10953 ! in its local coordinate system.
10954 !
10955 ! The derivatives are stored in the following arrays:
10956 !
10957 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
10958 ! The structure is as follows:
10959 !
10960 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
10961 ! 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)
10962 !         . . . . . . . . . . . .  . . . . . .
10963 ! 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)
10964 !                          .
10965 !                          .
10966 !                          .
10967 ! 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)
10968 !
10969 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
10970 ! The structure is same as above.
10971 !
10972 ! DCDS - the derivatives of the side chain vectors in the local spherical
10973 ! andgles alph and omega:
10974 !
10975 ! 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)
10976 ! 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)
10977 !                          .
10978 !                          .
10979 !                          .
10980 ! 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)
10981 !
10982 ! Version of March '95, based on an early version of November '91.
10983 !
10984 !**********************************************************************
10985 !      implicit real*8 (a-h,o-z)
10986 !      include 'DIMENSIONS'
10987 !      include 'COMMON.VAR'
10988 !      include 'COMMON.CHAIN'
10989 !      include 'COMMON.DERIV'
10990 !      include 'COMMON.GEO'
10991 !      include 'COMMON.LOCAL'
10992 !      include 'COMMON.INTERACT'
10993       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
10994       real(kind=8),dimension(3,3) :: dp,temp
10995 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
10996       real(kind=8),dimension(3) :: xx,xx1
10997 !el local variables
10998       integer :: i,k,l,j,m,ind,ind1,jjj
10999       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11000                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11001                  sint2,xp,yp,xxp,yyp,zzp,dj
11002
11003 !      common /przechowalnia/ fromto
11004       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11005 ! get the position of the jth ijth fragment of the chain coordinate system
11006 ! in the fromto array.
11007 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11008 !
11009 !      maxdim=(nres-1)*(nres-2)/2
11010 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11011 ! calculate the derivatives of transformation matrix elements in theta
11012 !
11013
11014 !el      call flush(iout) !el
11015       do i=1,nres-2
11016         rdt(1,1,i)=-rt(1,2,i)
11017         rdt(1,2,i)= rt(1,1,i)
11018         rdt(1,3,i)= 0.0d0
11019         rdt(2,1,i)=-rt(2,2,i)
11020         rdt(2,2,i)= rt(2,1,i)
11021         rdt(2,3,i)= 0.0d0
11022         rdt(3,1,i)=-rt(3,2,i)
11023         rdt(3,2,i)= rt(3,1,i)
11024         rdt(3,3,i)= 0.0d0
11025       enddo
11026 !
11027 ! derivatives in phi
11028 !
11029       do i=2,nres-2
11030         drt(1,1,i)= 0.0d0
11031         drt(1,2,i)= 0.0d0
11032         drt(1,3,i)= 0.0d0
11033         drt(2,1,i)= rt(3,1,i)
11034         drt(2,2,i)= rt(3,2,i)
11035         drt(2,3,i)= rt(3,3,i)
11036         drt(3,1,i)=-rt(2,1,i)
11037         drt(3,2,i)=-rt(2,2,i)
11038         drt(3,3,i)=-rt(2,3,i)
11039       enddo
11040 !
11041 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11042 !
11043       do i=2,nres-2
11044         ind=indmat(i,i+1)
11045         do k=1,3
11046           do l=1,3
11047             temp(k,l)=rt(k,l,i)
11048           enddo
11049         enddo
11050         do k=1,3
11051           do l=1,3
11052             fromto(k,l,ind)=temp(k,l)
11053           enddo
11054         enddo
11055         do j=i+1,nres-2
11056           ind=indmat(i,j+1)
11057           do k=1,3
11058             do l=1,3
11059               dpkl=0.0d0
11060               do m=1,3
11061                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11062               enddo
11063               dp(k,l)=dpkl
11064               fromto(k,l,ind)=dpkl
11065             enddo
11066           enddo
11067           do k=1,3
11068             do l=1,3
11069               temp(k,l)=dp(k,l)
11070             enddo
11071           enddo
11072         enddo
11073       enddo
11074 !
11075 ! Calculate derivatives.
11076 !
11077       ind1=0
11078       do i=1,nres-2
11079         ind1=ind1+1
11080 !
11081 ! Derivatives of DC(i+1) in theta(i+2)
11082 !
11083         do j=1,3
11084           do k=1,2
11085             dpjk=0.0D0
11086             do l=1,3
11087               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11088             enddo
11089             dp(j,k)=dpjk
11090             prordt(j,k,i)=dp(j,k)
11091           enddo
11092           dp(j,3)=0.0D0
11093           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11094         enddo
11095 !
11096 ! Derivatives of SC(i+1) in theta(i+2)
11097 !
11098         xx1(1)=-0.5D0*xloc(2,i+1)
11099         xx1(2)= 0.5D0*xloc(1,i+1)
11100         do j=1,3
11101           xj=0.0D0
11102           do k=1,2
11103             xj=xj+r(j,k,i)*xx1(k)
11104           enddo
11105           xx(j)=xj
11106         enddo
11107         do j=1,3
11108           rj=0.0D0
11109           do k=1,3
11110             rj=rj+prod(j,k,i)*xx(k)
11111           enddo
11112           dxdv(j,ind1)=rj
11113         enddo
11114 !
11115 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11116 ! than the other off-diagonal derivatives.
11117 !
11118         do j=1,3
11119           dxoiij=0.0D0
11120           do k=1,3
11121             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11122           enddo
11123           dxdv(j,ind1+1)=dxoiij
11124         enddo
11125 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11126 !
11127 ! Derivatives of DC(i+1) in phi(i+2)
11128 !
11129         do j=1,3
11130           do k=1,3
11131             dpjk=0.0
11132             do l=2,3
11133               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11134             enddo
11135             dp(j,k)=dpjk
11136             prodrt(j,k,i)=dp(j,k)
11137           enddo
11138           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11139         enddo
11140 !
11141 ! Derivatives of SC(i+1) in phi(i+2)
11142 !
11143         xx(1)= 0.0D0
11144         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11145         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11146         do j=1,3
11147           rj=0.0D0
11148           do k=2,3
11149             rj=rj+prod(j,k,i)*xx(k)
11150           enddo
11151           dxdv(j+3,ind1)=-rj
11152         enddo
11153 !
11154 ! Derivatives of SC(i+1) in phi(i+3).
11155 !
11156         do j=1,3
11157           dxoiij=0.0D0
11158           do k=1,3
11159             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11160           enddo
11161           dxdv(j+3,ind1+1)=dxoiij
11162         enddo
11163 !
11164 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11165 ! theta(nres) and phi(i+3) thru phi(nres).
11166 !
11167         do j=i+1,nres-2
11168           ind1=ind1+1
11169           ind=indmat(i+1,j+1)
11170 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11171           do k=1,3
11172             do l=1,3
11173               tempkl=0.0D0
11174               do m=1,2
11175                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11176               enddo
11177               temp(k,l)=tempkl
11178             enddo
11179           enddo
11180 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11181 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11182 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11183 ! Derivatives of virtual-bond vectors in theta
11184           do k=1,3
11185             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11186           enddo
11187 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11188 ! Derivatives of SC vectors in theta
11189           do k=1,3
11190             dxoijk=0.0D0
11191             do l=1,3
11192               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11193             enddo
11194             dxdv(k,ind1+1)=dxoijk
11195           enddo
11196 !
11197 !--- Calculate the derivatives in phi
11198 !
11199           do k=1,3
11200             do l=1,3
11201               tempkl=0.0D0
11202               do m=1,3
11203                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11204               enddo
11205               temp(k,l)=tempkl
11206             enddo
11207           enddo
11208           do k=1,3
11209             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11210           enddo
11211           do k=1,3
11212             dxoijk=0.0D0
11213             do l=1,3
11214               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11215             enddo
11216             dxdv(k+3,ind1+1)=dxoijk
11217           enddo
11218         enddo
11219       enddo
11220 !
11221 ! Derivatives in alpha and omega:
11222 !
11223       do i=2,nres-1
11224 !       dsci=dsc(itype(i,1))
11225         dsci=vbld(i+nres)
11226 #ifdef OSF
11227         alphi=alph(i)
11228         omegi=omeg(i)
11229         if(alphi.ne.alphi) alphi=100.0
11230         if(omegi.ne.omegi) omegi=-100.0
11231 #else
11232         alphi=alph(i)
11233         omegi=omeg(i)
11234 #endif
11235 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11236         cosalphi=dcos(alphi)
11237         sinalphi=dsin(alphi)
11238         cosomegi=dcos(omegi)
11239         sinomegi=dsin(omegi)
11240         temp(1,1)=-dsci*sinalphi
11241         temp(2,1)= dsci*cosalphi*cosomegi
11242         temp(3,1)=-dsci*cosalphi*sinomegi
11243         temp(1,2)=0.0D0
11244         temp(2,2)=-dsci*sinalphi*sinomegi
11245         temp(3,2)=-dsci*sinalphi*cosomegi
11246         theta2=pi-0.5D0*theta(i+1)
11247         cost2=dcos(theta2)
11248         sint2=dsin(theta2)
11249         jjj=0
11250 !d      print *,((temp(l,k),l=1,3),k=1,2)
11251         do j=1,2
11252           xp=temp(1,j)
11253           yp=temp(2,j)
11254           xxp= xp*cost2+yp*sint2
11255           yyp=-xp*sint2+yp*cost2
11256           zzp=temp(3,j)
11257           xx(1)=xxp
11258           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11259           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11260           do k=1,3
11261             dj=0.0D0
11262             do l=1,3
11263               dj=dj+prod(k,l,i-1)*xx(l)
11264             enddo
11265             dxds(jjj+k,i)=dj
11266           enddo
11267           jjj=jjj+3
11268         enddo
11269       enddo
11270       return
11271       end subroutine cartder
11272 !-----------------------------------------------------------------------------
11273 ! checkder_p.F
11274 !-----------------------------------------------------------------------------
11275       subroutine check_cartgrad
11276 ! Check the gradient of Cartesian coordinates in internal coordinates.
11277 !      implicit real*8 (a-h,o-z)
11278 !      include 'DIMENSIONS'
11279 !      include 'COMMON.IOUNITS'
11280 !      include 'COMMON.VAR'
11281 !      include 'COMMON.CHAIN'
11282 !      include 'COMMON.GEO'
11283 !      include 'COMMON.LOCAL'
11284 !      include 'COMMON.DERIV'
11285       real(kind=8),dimension(6,nres) :: temp
11286       real(kind=8),dimension(3) :: xx,gg
11287       integer :: i,k,j,ii
11288       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11289 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11290 !
11291 ! Check the gradient of the virtual-bond and SC vectors in the internal
11292 ! coordinates.
11293 !
11294       aincr=1.0d-6
11295       aincr2=5.0d-7
11296       call cartder
11297       write (iout,'(a)') '**************** dx/dalpha'
11298       write (iout,'(a)')
11299       do i=2,nres-1
11300         alphi=alph(i)
11301         alph(i)=alph(i)+aincr
11302         do k=1,3
11303           temp(k,i)=dc(k,nres+i)
11304         enddo
11305         call chainbuild
11306         do k=1,3
11307           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11308           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11309         enddo
11310         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11311         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11312         write (iout,'(a)')
11313         alph(i)=alphi
11314         call chainbuild
11315       enddo
11316       write (iout,'(a)')
11317       write (iout,'(a)') '**************** dx/domega'
11318       write (iout,'(a)')
11319       do i=2,nres-1
11320         omegi=omeg(i)
11321         omeg(i)=omeg(i)+aincr
11322         do k=1,3
11323           temp(k,i)=dc(k,nres+i)
11324         enddo
11325         call chainbuild
11326         do k=1,3
11327           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11328           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11329                 (aincr*dabs(dxds(k+3,i))+aincr))
11330         enddo
11331         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11332             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11333         write (iout,'(a)')
11334         omeg(i)=omegi
11335         call chainbuild
11336       enddo
11337       write (iout,'(a)')
11338       write (iout,'(a)') '**************** dx/dtheta'
11339       write (iout,'(a)')
11340       do i=3,nres
11341         theti=theta(i)
11342         theta(i)=theta(i)+aincr
11343         do j=i-1,nres-1
11344           do k=1,3
11345             temp(k,j)=dc(k,nres+j)
11346           enddo
11347         enddo
11348         call chainbuild
11349         do j=i-1,nres-1
11350           ii = indmat(i-2,j)
11351 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11352           do k=1,3
11353             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11354             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11355                   (aincr*dabs(dxdv(k,ii))+aincr))
11356           enddo
11357           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11358               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11359           write(iout,'(a)')
11360         enddo
11361         write (iout,'(a)')
11362         theta(i)=theti
11363         call chainbuild
11364       enddo
11365       write (iout,'(a)') '***************** dx/dphi'
11366       write (iout,'(a)')
11367       do i=4,nres
11368         phi(i)=phi(i)+aincr
11369         do j=i-1,nres-1
11370           do k=1,3
11371             temp(k,j)=dc(k,nres+j)
11372           enddo
11373         enddo
11374         call chainbuild
11375         do j=i-1,nres-1
11376           ii = indmat(i-2,j)
11377 !         print *,'ii=',ii
11378           do k=1,3
11379             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11380             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11381                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11382           enddo
11383           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11384               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11385           write(iout,'(a)')
11386         enddo
11387         phi(i)=phi(i)-aincr
11388         call chainbuild
11389       enddo
11390       write (iout,'(a)') '****************** ddc/dtheta'
11391       do i=1,nres-2
11392         thet=theta(i+2)
11393         theta(i+2)=thet+aincr
11394         do j=i,nres
11395           do k=1,3
11396             temp(k,j)=dc(k,j)
11397           enddo
11398         enddo
11399         call chainbuild
11400         do j=i+1,nres-1
11401           ii = indmat(i,j)
11402 !         print *,'ii=',ii
11403           do k=1,3
11404             gg(k)=(dc(k,j)-temp(k,j))/aincr
11405             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11406                  (aincr*dabs(dcdv(k,ii))+aincr))
11407           enddo
11408           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11409                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11410           write (iout,'(a)')
11411         enddo
11412         do j=1,nres
11413           do k=1,3
11414             dc(k,j)=temp(k,j)
11415           enddo
11416         enddo
11417         theta(i+2)=thet
11418       enddo
11419       write (iout,'(a)') '******************* ddc/dphi'
11420       do i=1,nres-3
11421         phii=phi(i+3)
11422         phi(i+3)=phii+aincr
11423         do j=1,nres
11424           do k=1,3
11425             temp(k,j)=dc(k,j)
11426           enddo
11427         enddo
11428         call chainbuild
11429         do j=i+2,nres-1
11430           ii = indmat(i+1,j)
11431 !         print *,'ii=',ii
11432           do k=1,3
11433             gg(k)=(dc(k,j)-temp(k,j))/aincr
11434             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11435                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11436           enddo
11437           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11438                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11439           write (iout,'(a)')
11440         enddo
11441         do j=1,nres
11442           do k=1,3
11443             dc(k,j)=temp(k,j)
11444           enddo
11445         enddo
11446         phi(i+3)=phii
11447       enddo
11448       return
11449       end subroutine check_cartgrad
11450 !-----------------------------------------------------------------------------
11451       subroutine check_ecart
11452 ! Check the gradient of the energy in Cartesian coordinates.
11453 !     implicit real*8 (a-h,o-z)
11454 !     include 'DIMENSIONS'
11455 !     include 'COMMON.CHAIN'
11456 !     include 'COMMON.DERIV'
11457 !     include 'COMMON.IOUNITS'
11458 !     include 'COMMON.VAR'
11459 !     include 'COMMON.CONTACTS'
11460       use comm_srutu
11461 !el      integer :: icall
11462 !el      common /srutu/ icall
11463       real(kind=8),dimension(6) :: ggg
11464       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11465       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11466       real(kind=8),dimension(6,nres) :: grad_s
11467       real(kind=8),dimension(0:n_ene) :: energia,energia1
11468       integer :: uiparm(1)
11469       real(kind=8) :: urparm(1)
11470 !EL      external fdum
11471       integer :: nf,i,j,k
11472       real(kind=8) :: aincr,etot,etot1
11473       icg=1
11474       nf=0
11475       nfl=0
11476       call zerograd
11477       aincr=1.0D-5
11478       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11479       nf=0
11480       icall=0
11481       call geom_to_var(nvar,x)
11482       call etotal(energia)
11483       etot=energia(0)
11484 !el      call enerprint(energia)
11485       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11486       icall =1
11487       do i=1,nres
11488         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11489       enddo
11490       do i=1,nres
11491         do j=1,3
11492           grad_s(j,i)=gradc(j,i,icg)
11493           grad_s(j+3,i)=gradx(j,i,icg)
11494         enddo
11495       enddo
11496       call flush(iout)
11497       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11498       do i=1,nres
11499         do j=1,3
11500           xx(j)=c(j,i+nres)
11501           ddc(j)=dc(j,i)
11502           ddx(j)=dc(j,i+nres)
11503         enddo
11504         do j=1,3
11505           dc(j,i)=dc(j,i)+aincr
11506           do k=i+1,nres
11507             c(j,k)=c(j,k)+aincr
11508             c(j,k+nres)=c(j,k+nres)+aincr
11509           enddo
11510           call etotal(energia1)
11511           etot1=energia1(0)
11512           ggg(j)=(etot1-etot)/aincr
11513           dc(j,i)=ddc(j)
11514           do k=i+1,nres
11515             c(j,k)=c(j,k)-aincr
11516             c(j,k+nres)=c(j,k+nres)-aincr
11517           enddo
11518         enddo
11519         do j=1,3
11520           c(j,i+nres)=c(j,i+nres)+aincr
11521           dc(j,i+nres)=dc(j,i+nres)+aincr
11522           call etotal(energia1)
11523           etot1=energia1(0)
11524           ggg(j+3)=(etot1-etot)/aincr
11525           c(j,i+nres)=xx(j)
11526           dc(j,i+nres)=ddx(j)
11527         enddo
11528         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11529          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11530       enddo
11531       return
11532       end subroutine check_ecart
11533 #ifdef CARGRAD
11534 !-----------------------------------------------------------------------------
11535       subroutine check_ecartint
11536 ! Check the gradient of the energy in Cartesian coordinates.
11537       use io_base, only: intout
11538 !      implicit real*8 (a-h,o-z)
11539 !      include 'DIMENSIONS'
11540 !      include 'COMMON.CONTROL'
11541 !      include 'COMMON.CHAIN'
11542 !      include 'COMMON.DERIV'
11543 !      include 'COMMON.IOUNITS'
11544 !      include 'COMMON.VAR'
11545 !      include 'COMMON.CONTACTS'
11546 !      include 'COMMON.MD'
11547 !      include 'COMMON.LOCAL'
11548 !      include 'COMMON.SPLITELE'
11549       use comm_srutu
11550 !el      integer :: icall
11551 !el      common /srutu/ icall
11552       real(kind=8),dimension(6) :: ggg,ggg1
11553       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11554       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11555       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11556       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11557       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11558       real(kind=8),dimension(0:n_ene) :: energia,energia1
11559       integer :: uiparm(1)
11560       real(kind=8) :: urparm(1)
11561 !EL      external fdum
11562       integer :: i,j,k,nf
11563       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11564                    etot21,etot22
11565       r_cut=2.0d0
11566       rlambd=0.3d0
11567       icg=1
11568       nf=0
11569       nfl=0
11570       call intout
11571 !      call intcartderiv
11572 !      call checkintcartgrad
11573       call zerograd
11574       aincr=1.0D-5
11575       write(iout,*) 'Calling CHECK_ECARTINT.'
11576       nf=0
11577       icall=0
11578       write (iout,*) "Before geom_to_var"
11579       call geom_to_var(nvar,x)
11580       write (iout,*) "after geom_to_var"
11581       write (iout,*) "split_ene ",split_ene
11582       call flush(iout)
11583       if (.not.split_ene) then
11584         write(iout,*) 'Calling CHECK_ECARTINT if'
11585         call etotal(energia)
11586 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11587         etot=energia(0)
11588         write (iout,*) "etot",etot
11589         call flush(iout)
11590 !el        call enerprint(energia)
11591 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11592         call flush(iout)
11593         write (iout,*) "enter cartgrad"
11594         call flush(iout)
11595         call cartgrad
11596 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11597         write (iout,*) "exit cartgrad"
11598         call flush(iout)
11599         icall =1
11600         do i=1,nres
11601           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11602         enddo
11603         do j=1,3
11604           grad_s(j,0)=gcart(j,0)
11605         enddo
11606 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11607         do i=1,nres
11608           do j=1,3
11609             grad_s(j,i)=gcart(j,i)
11610             grad_s(j+3,i)=gxcart(j,i)
11611           enddo
11612         enddo
11613       else
11614 write(iout,*) 'Calling CHECK_ECARTIN else.'
11615 !- split gradient check
11616         call zerograd
11617         call etotal_long(energia)
11618 !el        call enerprint(energia)
11619         call flush(iout)
11620         write (iout,*) "enter cartgrad"
11621         call flush(iout)
11622         call cartgrad
11623         write (iout,*) "exit cartgrad"
11624         call flush(iout)
11625         icall =1
11626         write (iout,*) "longrange grad"
11627         do i=1,nres
11628           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11629           (gxcart(j,i),j=1,3)
11630         enddo
11631         do j=1,3
11632           grad_s(j,0)=gcart(j,0)
11633         enddo
11634         do i=1,nres
11635           do j=1,3
11636             grad_s(j,i)=gcart(j,i)
11637             grad_s(j+3,i)=gxcart(j,i)
11638           enddo
11639         enddo
11640         call zerograd
11641         call etotal_short(energia)
11642 !el        call enerprint(energia)
11643         call flush(iout)
11644         write (iout,*) "enter cartgrad"
11645         call flush(iout)
11646         call cartgrad
11647         write (iout,*) "exit cartgrad"
11648         call flush(iout)
11649         icall =1
11650         write (iout,*) "shortrange grad"
11651         do i=1,nres
11652           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11653           (gxcart(j,i),j=1,3)
11654         enddo
11655         do j=1,3
11656           grad_s1(j,0)=gcart(j,0)
11657         enddo
11658         do i=1,nres
11659           do j=1,3
11660             grad_s1(j,i)=gcart(j,i)
11661             grad_s1(j+3,i)=gxcart(j,i)
11662           enddo
11663         enddo
11664       endif
11665       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11666 !      do i=1,nres
11667       do i=nnt,nct
11668         do j=1,3
11669           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11670           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11671           ddc(j)=c(j,i)
11672           ddx(j)=c(j,i+nres)
11673           dcnorm_safe1(j)=dc_norm(j,i-1)
11674           dcnorm_safe2(j)=dc_norm(j,i)
11675           dxnorm_safe(j)=dc_norm(j,i+nres)
11676         enddo
11677         do j=1,3
11678           c(j,i)=ddc(j)+aincr
11679           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11680           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11681           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11682           dc(j,i)=c(j,i+1)-c(j,i)
11683           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11684           call int_from_cart1(.false.)
11685           if (.not.split_ene) then
11686             call etotal(energia1)
11687             etot1=energia1(0)
11688             write (iout,*) "ij",i,j," etot1",etot1
11689           else
11690 !- split gradient
11691             call etotal_long(energia1)
11692             etot11=energia1(0)
11693             call etotal_short(energia1)
11694             etot12=energia1(0)
11695           endif
11696 !- end split gradient
11697 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11698           c(j,i)=ddc(j)-aincr
11699           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11700           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11701           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11702           dc(j,i)=c(j,i+1)-c(j,i)
11703           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11704           call int_from_cart1(.false.)
11705           if (.not.split_ene) then
11706             call etotal(energia1)
11707             etot2=energia1(0)
11708             write (iout,*) "ij",i,j," etot2",etot2
11709             ggg(j)=(etot1-etot2)/(2*aincr)
11710           else
11711 !- split gradient
11712             call etotal_long(energia1)
11713             etot21=energia1(0)
11714             ggg(j)=(etot11-etot21)/(2*aincr)
11715             call etotal_short(energia1)
11716             etot22=energia1(0)
11717             ggg1(j)=(etot12-etot22)/(2*aincr)
11718 !- end split gradient
11719 !            write (iout,*) "etot21",etot21," etot22",etot22
11720           endif
11721 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11722           c(j,i)=ddc(j)
11723           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11724           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11725           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11726           dc(j,i)=c(j,i+1)-c(j,i)
11727           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11728           dc_norm(j,i-1)=dcnorm_safe1(j)
11729           dc_norm(j,i)=dcnorm_safe2(j)
11730           dc_norm(j,i+nres)=dxnorm_safe(j)
11731         enddo
11732         do j=1,3
11733           c(j,i+nres)=ddx(j)+aincr
11734           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11735           call int_from_cart1(.false.)
11736           if (.not.split_ene) then
11737             call etotal(energia1)
11738             etot1=energia1(0)
11739           else
11740 !- split gradient
11741             call etotal_long(energia1)
11742             etot11=energia1(0)
11743             call etotal_short(energia1)
11744             etot12=energia1(0)
11745           endif
11746 !- end split gradient
11747           c(j,i+nres)=ddx(j)-aincr
11748           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11749           call int_from_cart1(.false.)
11750           if (.not.split_ene) then
11751             call etotal(energia1)
11752             etot2=energia1(0)
11753             ggg(j+3)=(etot1-etot2)/(2*aincr)
11754           else
11755 !- split gradient
11756             call etotal_long(energia1)
11757             etot21=energia1(0)
11758             ggg(j+3)=(etot11-etot21)/(2*aincr)
11759             call etotal_short(energia1)
11760             etot22=energia1(0)
11761             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11762 !- end split gradient
11763           endif
11764 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11765           c(j,i+nres)=ddx(j)
11766           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11767           dc_norm(j,i+nres)=dxnorm_safe(j)
11768           call int_from_cart1(.false.)
11769         enddo
11770         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11771          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11772         if (split_ene) then
11773           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11774          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11775          k=1,6)
11776          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11777          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11778          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11779         endif
11780       enddo
11781       return
11782       end subroutine check_ecartint
11783 #else
11784 !-----------------------------------------------------------------------------
11785       subroutine check_ecartint
11786 ! Check the gradient of the energy in Cartesian coordinates.
11787       use io_base, only: intout
11788 !      implicit real*8 (a-h,o-z)
11789 !      include 'DIMENSIONS'
11790 !      include 'COMMON.CONTROL'
11791 !      include 'COMMON.CHAIN'
11792 !      include 'COMMON.DERIV'
11793 !      include 'COMMON.IOUNITS'
11794 !      include 'COMMON.VAR'
11795 !      include 'COMMON.CONTACTS'
11796 !      include 'COMMON.MD'
11797 !      include 'COMMON.LOCAL'
11798 !      include 'COMMON.SPLITELE'
11799       use comm_srutu
11800 !el      integer :: icall
11801 !el      common /srutu/ icall
11802       real(kind=8),dimension(6) :: ggg,ggg1
11803       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11804       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11805       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
11806       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11807       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11808       real(kind=8),dimension(0:n_ene) :: energia,energia1
11809       integer :: uiparm(1)
11810       real(kind=8) :: urparm(1)
11811 !EL      external fdum
11812       integer :: i,j,k,nf
11813       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11814                    etot21,etot22
11815       r_cut=2.0d0
11816       rlambd=0.3d0
11817       icg=1
11818       nf=0
11819       nfl=0
11820       call intout
11821 !      call intcartderiv
11822 !      call checkintcartgrad
11823       call zerograd
11824       aincr=2.0D-5
11825       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
11826       nf=0
11827       icall=0
11828       call geom_to_var(nvar,x)
11829       if (.not.split_ene) then
11830         call etotal(energia)
11831         etot=energia(0)
11832 !el        call enerprint(energia)
11833         call flush(iout)
11834         write (iout,*) "enter cartgrad"
11835         call flush(iout)
11836         call cartgrad
11837         write (iout,*) "exit cartgrad"
11838         call flush(iout)
11839         icall =1
11840         do i=1,nres
11841           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11842         enddo
11843         do j=1,3
11844           grad_s(j,0)=gcart(j,0)
11845         enddo
11846         do i=1,nres
11847           do j=1,3
11848             grad_s(j,i)=gcart(j,i)
11849             grad_s(j+3,i)=gxcart(j,i)
11850           enddo
11851         enddo
11852       else
11853 !- split gradient check
11854         call zerograd
11855         call etotal_long(energia)
11856 !el        call enerprint(energia)
11857         call flush(iout)
11858         write (iout,*) "enter cartgrad"
11859         call flush(iout)
11860         call cartgrad
11861         write (iout,*) "exit cartgrad"
11862         call flush(iout)
11863         icall =1
11864         write (iout,*) "longrange grad"
11865         do i=1,nres
11866           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11867           (gxcart(j,i),j=1,3)
11868         enddo
11869         do j=1,3
11870           grad_s(j,0)=gcart(j,0)
11871         enddo
11872         do i=1,nres
11873           do j=1,3
11874             grad_s(j,i)=gcart(j,i)
11875             grad_s(j+3,i)=gxcart(j,i)
11876           enddo
11877         enddo
11878         call zerograd
11879         call etotal_short(energia)
11880 !el        call enerprint(energia)
11881         call flush(iout)
11882         write (iout,*) "enter cartgrad"
11883         call flush(iout)
11884         call cartgrad
11885         write (iout,*) "exit cartgrad"
11886         call flush(iout)
11887         icall =1
11888         write (iout,*) "shortrange grad"
11889         do i=1,nres
11890           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11891           (gxcart(j,i),j=1,3)
11892         enddo
11893         do j=1,3
11894           grad_s1(j,0)=gcart(j,0)
11895         enddo
11896         do i=1,nres
11897           do j=1,3
11898             grad_s1(j,i)=gcart(j,i)
11899             grad_s1(j+3,i)=gxcart(j,i)
11900           enddo
11901         enddo
11902       endif
11903       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11904       do i=0,nres
11905         do j=1,3
11906           xx(j)=c(j,i+nres)
11907           ddc(j)=dc(j,i)
11908           ddx(j)=dc(j,i+nres)
11909           do k=1,3
11910             dcnorm_safe(k)=dc_norm(k,i)
11911             dxnorm_safe(k)=dc_norm(k,i+nres)
11912           enddo
11913         enddo
11914         do j=1,3
11915           dc(j,i)=ddc(j)+aincr
11916           call chainbuild_cart
11917 #ifdef MPI
11918 ! Broadcast the order to compute internal coordinates to the slaves.
11919 !          if (nfgtasks.gt.1)
11920 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
11921 #endif
11922 !          call int_from_cart1(.false.)
11923           if (.not.split_ene) then
11924             call etotal(energia1)
11925             etot1=energia1(0)
11926           else
11927 !- split gradient
11928             call etotal_long(energia1)
11929             etot11=energia1(0)
11930             call etotal_short(energia1)
11931             etot12=energia1(0)
11932 !            write (iout,*) "etot11",etot11," etot12",etot12
11933           endif
11934 !- end split gradient
11935 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11936           dc(j,i)=ddc(j)-aincr
11937           call chainbuild_cart
11938 !          call int_from_cart1(.false.)
11939           if (.not.split_ene) then
11940             call etotal(energia1)
11941             etot2=energia1(0)
11942             ggg(j)=(etot1-etot2)/(2*aincr)
11943           else
11944 !- split gradient
11945             call etotal_long(energia1)
11946             etot21=energia1(0)
11947             ggg(j)=(etot11-etot21)/(2*aincr)
11948             call etotal_short(energia1)
11949             etot22=energia1(0)
11950             ggg1(j)=(etot12-etot22)/(2*aincr)
11951 !- end split gradient
11952 !            write (iout,*) "etot21",etot21," etot22",etot22
11953           endif
11954 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11955           dc(j,i)=ddc(j)
11956           call chainbuild_cart
11957         enddo
11958         do j=1,3
11959           dc(j,i+nres)=ddx(j)+aincr
11960           call chainbuild_cart
11961 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
11962 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11963 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11964 !          write (iout,*) "dxnormnorm",dsqrt(
11965 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11966 !          write (iout,*) "dxnormnormsafe",dsqrt(
11967 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11968 !          write (iout,*)
11969           if (.not.split_ene) then
11970             call etotal(energia1)
11971             etot1=energia1(0)
11972           else
11973 !- split gradient
11974             call etotal_long(energia1)
11975             etot11=energia1(0)
11976             call etotal_short(energia1)
11977             etot12=energia1(0)
11978           endif
11979 !- end split gradient
11980 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11981           dc(j,i+nres)=ddx(j)-aincr
11982           call chainbuild_cart
11983 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
11984 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11985 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11986 !          write (iout,*)
11987 !          write (iout,*) "dxnormnorm",dsqrt(
11988 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11989 !          write (iout,*) "dxnormnormsafe",dsqrt(
11990 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11991           if (.not.split_ene) then
11992             call etotal(energia1)
11993             etot2=energia1(0)
11994             ggg(j+3)=(etot1-etot2)/(2*aincr)
11995           else
11996 !- split gradient
11997             call etotal_long(energia1)
11998             etot21=energia1(0)
11999             ggg(j+3)=(etot11-etot21)/(2*aincr)
12000             call etotal_short(energia1)
12001             etot22=energia1(0)
12002             ggg1(j+3)=(etot12-etot22)/(2*aincr)
12003 !- end split gradient
12004           endif
12005 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12006           dc(j,i+nres)=ddx(j)
12007           call chainbuild_cart
12008         enddo
12009         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12010          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12011         if (split_ene) then
12012           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12013          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12014          k=1,6)
12015          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12016          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12017          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12018         endif
12019       enddo
12020       return
12021       end subroutine check_ecartint
12022 #endif
12023 !-----------------------------------------------------------------------------
12024       subroutine check_eint
12025 ! Check the gradient of energy in internal coordinates.
12026 !      implicit real*8 (a-h,o-z)
12027 !      include 'DIMENSIONS'
12028 !      include 'COMMON.CHAIN'
12029 !      include 'COMMON.DERIV'
12030 !      include 'COMMON.IOUNITS'
12031 !      include 'COMMON.VAR'
12032 !      include 'COMMON.GEO'
12033       use comm_srutu
12034 !el      integer :: icall
12035 !el      common /srutu/ icall
12036       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12037       integer :: uiparm(1)
12038       real(kind=8) :: urparm(1)
12039       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12040       character(len=6) :: key
12041 !EL      external fdum
12042       integer :: i,ii,nf
12043       real(kind=8) :: xi,aincr,etot,etot1,etot2
12044       call zerograd
12045       aincr=1.0D-7
12046       print '(a)','Calling CHECK_INT.'
12047       nf=0
12048       nfl=0
12049       icg=1
12050       call geom_to_var(nvar,x)
12051       call var_to_geom(nvar,x)
12052       call chainbuild
12053       icall=1
12054       print *,'ICG=',ICG
12055       call etotal(energia)
12056       etot = energia(0)
12057 !el      call enerprint(energia)
12058       print *,'ICG=',ICG
12059 #ifdef MPL
12060       if (MyID.ne.BossID) then
12061         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12062         nf=x(nvar+1)
12063         nfl=x(nvar+2)
12064         icg=x(nvar+3)
12065       endif
12066 #endif
12067       nf=1
12068       nfl=3
12069 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12070       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12071 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12072       icall=1
12073       do i=1,nvar
12074         xi=x(i)
12075         x(i)=xi-0.5D0*aincr
12076         call var_to_geom(nvar,x)
12077         call chainbuild
12078         call etotal(energia1)
12079         etot1=energia1(0)
12080         x(i)=xi+0.5D0*aincr
12081         call var_to_geom(nvar,x)
12082         call chainbuild
12083         call etotal(energia2)
12084         etot2=energia2(0)
12085         gg(i)=(etot2-etot1)/aincr
12086         write (iout,*) i,etot1,etot2
12087         x(i)=xi
12088       enddo
12089       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12090           '     RelDiff*100% '
12091       do i=1,nvar
12092         if (i.le.nphi) then
12093           ii=i
12094           key = ' phi'
12095         else if (i.le.nphi+ntheta) then
12096           ii=i-nphi
12097           key=' theta'
12098         else if (i.le.nphi+ntheta+nside) then
12099            ii=i-(nphi+ntheta)
12100            key=' alpha'
12101         else
12102            ii=i-(nphi+ntheta+nside)
12103            key=' omega'
12104         endif
12105         write (iout,'(i3,a,i3,3(1pd16.6))') &
12106        i,key,ii,gg(i),gana(i),&
12107        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12108       enddo
12109       return
12110       end subroutine check_eint
12111 !-----------------------------------------------------------------------------
12112 ! econstr_local.F
12113 !-----------------------------------------------------------------------------
12114       subroutine Econstr_back
12115 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12116 !      implicit real*8 (a-h,o-z)
12117 !      include 'DIMENSIONS'
12118 !      include 'COMMON.CONTROL'
12119 !      include 'COMMON.VAR'
12120 !      include 'COMMON.MD'
12121       use MD_data
12122 !#ifndef LANG0
12123 !      include 'COMMON.LANGEVIN'
12124 !#else
12125 !      include 'COMMON.LANGEVIN.lang0'
12126 !#endif
12127 !      include 'COMMON.CHAIN'
12128 !      include 'COMMON.DERIV'
12129 !      include 'COMMON.GEO'
12130 !      include 'COMMON.LOCAL'
12131 !      include 'COMMON.INTERACT'
12132 !      include 'COMMON.IOUNITS'
12133 !      include 'COMMON.NAMES'
12134 !      include 'COMMON.TIME1'
12135       integer :: i,j,ii,k
12136       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12137
12138       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12139       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12140       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12141
12142       Uconst_back=0.0d0
12143       do i=1,nres
12144         dutheta(i)=0.0d0
12145         dugamma(i)=0.0d0
12146         do j=1,3
12147           duscdiff(j,i)=0.0d0
12148           duscdiffx(j,i)=0.0d0
12149         enddo
12150       enddo
12151       do i=1,nfrag_back
12152         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12153 !
12154 ! Deviations from theta angles
12155 !
12156         utheta_i=0.0d0
12157         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12158           dtheta_i=theta(j)-thetaref(j)
12159           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12160           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12161         enddo
12162         utheta(i)=utheta_i/(ii-1)
12163 !
12164 ! Deviations from gamma angles
12165 !
12166         ugamma_i=0.0d0
12167         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12168           dgamma_i=pinorm(phi(j)-phiref(j))
12169 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12170           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12171           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12172 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12173         enddo
12174         ugamma(i)=ugamma_i/(ii-2)
12175 !
12176 ! Deviations from local SC geometry
12177 !
12178         uscdiff(i)=0.0d0
12179         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12180           dxx=xxtab(j)-xxref(j)
12181           dyy=yytab(j)-yyref(j)
12182           dzz=zztab(j)-zzref(j)
12183           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12184           do k=1,3
12185             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12186              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12187              (ii-1)
12188             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12189              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12190              (ii-1)
12191             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12192            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12193             /(ii-1)
12194           enddo
12195 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12196 !     &      xxref(j),yyref(j),zzref(j)
12197         enddo
12198         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12199 !        write (iout,*) i," uscdiff",uscdiff(i)
12200 !
12201 ! Put together deviations from local geometry
12202 !
12203         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12204           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12205 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12206 !     &   " uconst_back",uconst_back
12207         utheta(i)=dsqrt(utheta(i))
12208         ugamma(i)=dsqrt(ugamma(i))
12209         uscdiff(i)=dsqrt(uscdiff(i))
12210       enddo
12211       return
12212       end subroutine Econstr_back
12213 !-----------------------------------------------------------------------------
12214 ! energy_p_new-sep_barrier.F
12215 !-----------------------------------------------------------------------------
12216       real(kind=8) function sscale(r)
12217 !      include "COMMON.SPLITELE"
12218       real(kind=8) :: r,gamm
12219       if(r.lt.r_cut-rlamb) then
12220         sscale=1.0d0
12221       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12222         gamm=(r-(r_cut-rlamb))/rlamb
12223         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12224       else
12225         sscale=0d0
12226       endif
12227       return
12228       end function sscale
12229       real(kind=8) function sscale_grad(r)
12230 !      include "COMMON.SPLITELE"
12231       real(kind=8) :: r,gamm
12232       if(r.lt.r_cut-rlamb) then
12233         sscale_grad=0.0d0
12234       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12235         gamm=(r-(r_cut-rlamb))/rlamb
12236         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12237       else
12238         sscale_grad=0d0
12239       endif
12240       return
12241       end function sscale_grad
12242
12243 !!!!!!!!!! PBCSCALE
12244       real(kind=8) function sscale_ele(r)
12245 !      include "COMMON.SPLITELE"
12246       real(kind=8) :: r,gamm
12247       if(r.lt.r_cut_ele-rlamb_ele) then
12248         sscale_ele=1.0d0
12249       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12250         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12251         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12252       else
12253         sscale_ele=0d0
12254       endif
12255       return
12256       end function sscale_ele
12257
12258       real(kind=8)  function sscagrad_ele(r)
12259       real(kind=8) :: r,gamm
12260 !      include "COMMON.SPLITELE"
12261       if(r.lt.r_cut_ele-rlamb_ele) then
12262         sscagrad_ele=0.0d0
12263       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12264         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12265         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12266       else
12267         sscagrad_ele=0.0d0
12268       endif
12269       return
12270       end function sscagrad_ele
12271       real(kind=8) function sscalelip(r)
12272       real(kind=8) r,gamm
12273         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12274       return
12275       end function sscalelip
12276 !C-----------------------------------------------------------------------
12277       real(kind=8) function sscagradlip(r)
12278       real(kind=8) r,gamm
12279         sscagradlip=r*(6.0d0*r-6.0d0)
12280       return
12281       end function sscagradlip
12282
12283 !!!!!!!!!!!!!!!
12284 !-----------------------------------------------------------------------------
12285       subroutine elj_long(evdw)
12286 !
12287 ! This subroutine calculates the interaction energy of nonbonded side chains
12288 ! assuming the LJ potential of interaction.
12289 !
12290 !      implicit real*8 (a-h,o-z)
12291 !      include 'DIMENSIONS'
12292 !      include 'COMMON.GEO'
12293 !      include 'COMMON.VAR'
12294 !      include 'COMMON.LOCAL'
12295 !      include 'COMMON.CHAIN'
12296 !      include 'COMMON.DERIV'
12297 !      include 'COMMON.INTERACT'
12298 !      include 'COMMON.TORSION'
12299 !      include 'COMMON.SBRIDGE'
12300 !      include 'COMMON.NAMES'
12301 !      include 'COMMON.IOUNITS'
12302 !      include 'COMMON.CONTACTS'
12303       real(kind=8),parameter :: accur=1.0d-10
12304       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12305 !el local variables
12306       integer :: i,iint,j,k,itypi,itypi1,itypj
12307       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12308       real(kind=8) :: e1,e2,evdwij,evdw
12309 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12310       evdw=0.0D0
12311       do i=iatsc_s,iatsc_e
12312         itypi=itype(i,1)
12313         if (itypi.eq.ntyp1) cycle
12314         itypi1=itype(i+1,1)
12315         xi=c(1,nres+i)
12316         yi=c(2,nres+i)
12317         zi=c(3,nres+i)
12318 !
12319 ! Calculate SC interaction energy.
12320 !
12321         do iint=1,nint_gr(i)
12322 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12323 !d   &                  'iend=',iend(i,iint)
12324           do j=istart(i,iint),iend(i,iint)
12325             itypj=itype(j,1)
12326             if (itypj.eq.ntyp1) cycle
12327             xj=c(1,nres+j)-xi
12328             yj=c(2,nres+j)-yi
12329             zj=c(3,nres+j)-zi
12330             rij=xj*xj+yj*yj+zj*zj
12331             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12332             if (sss.lt.1.0d0) then
12333               rrij=1.0D0/rij
12334               eps0ij=eps(itypi,itypj)
12335               fac=rrij**expon2
12336               e1=fac*fac*aa_aq(itypi,itypj)
12337               e2=fac*bb_aq(itypi,itypj)
12338               evdwij=e1+e2
12339               evdw=evdw+(1.0d0-sss)*evdwij
12340 !
12341 ! Calculate the components of the gradient in DC and X
12342 !
12343               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12344               gg(1)=xj*fac
12345               gg(2)=yj*fac
12346               gg(3)=zj*fac
12347               do k=1,3
12348                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12349                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12350                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12351                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12352               enddo
12353             endif
12354           enddo      ! j
12355         enddo        ! iint
12356       enddo          ! i
12357       do i=1,nct
12358         do j=1,3
12359           gvdwc(j,i)=expon*gvdwc(j,i)
12360           gvdwx(j,i)=expon*gvdwx(j,i)
12361         enddo
12362       enddo
12363 !******************************************************************************
12364 !
12365 !                              N O T E !!!
12366 !
12367 ! To save time, the factor of EXPON has been extracted from ALL components
12368 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12369 ! use!
12370 !
12371 !******************************************************************************
12372       return
12373       end subroutine elj_long
12374 !-----------------------------------------------------------------------------
12375       subroutine elj_short(evdw)
12376 !
12377 ! This subroutine calculates the interaction energy of nonbonded side chains
12378 ! assuming the LJ potential of interaction.
12379 !
12380 !      implicit real*8 (a-h,o-z)
12381 !      include 'DIMENSIONS'
12382 !      include 'COMMON.GEO'
12383 !      include 'COMMON.VAR'
12384 !      include 'COMMON.LOCAL'
12385 !      include 'COMMON.CHAIN'
12386 !      include 'COMMON.DERIV'
12387 !      include 'COMMON.INTERACT'
12388 !      include 'COMMON.TORSION'
12389 !      include 'COMMON.SBRIDGE'
12390 !      include 'COMMON.NAMES'
12391 !      include 'COMMON.IOUNITS'
12392 !      include 'COMMON.CONTACTS'
12393       real(kind=8),parameter :: accur=1.0d-10
12394       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12395 !el local variables
12396       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12397       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12398       real(kind=8) :: e1,e2,evdwij,evdw
12399 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12400       evdw=0.0D0
12401       do i=iatsc_s,iatsc_e
12402         itypi=itype(i,1)
12403         if (itypi.eq.ntyp1) cycle
12404         itypi1=itype(i+1,1)
12405         xi=c(1,nres+i)
12406         yi=c(2,nres+i)
12407         zi=c(3,nres+i)
12408 ! Change 12/1/95
12409         num_conti=0
12410 !
12411 ! Calculate SC interaction energy.
12412 !
12413         do iint=1,nint_gr(i)
12414 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12415 !d   &                  'iend=',iend(i,iint)
12416           do j=istart(i,iint),iend(i,iint)
12417             itypj=itype(j,1)
12418             if (itypj.eq.ntyp1) cycle
12419             xj=c(1,nres+j)-xi
12420             yj=c(2,nres+j)-yi
12421             zj=c(3,nres+j)-zi
12422 ! Change 12/1/95 to calculate four-body interactions
12423             rij=xj*xj+yj*yj+zj*zj
12424             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12425             if (sss.gt.0.0d0) then
12426               rrij=1.0D0/rij
12427               eps0ij=eps(itypi,itypj)
12428               fac=rrij**expon2
12429               e1=fac*fac*aa_aq(itypi,itypj)
12430               e2=fac*bb_aq(itypi,itypj)
12431               evdwij=e1+e2
12432               evdw=evdw+sss*evdwij
12433 !
12434 ! Calculate the components of the gradient in DC and X
12435 !
12436               fac=-rrij*(e1+evdwij)*sss
12437               gg(1)=xj*fac
12438               gg(2)=yj*fac
12439               gg(3)=zj*fac
12440               do k=1,3
12441                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12442                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12443                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12444                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12445               enddo
12446             endif
12447           enddo      ! j
12448         enddo        ! iint
12449       enddo          ! i
12450       do i=1,nct
12451         do j=1,3
12452           gvdwc(j,i)=expon*gvdwc(j,i)
12453           gvdwx(j,i)=expon*gvdwx(j,i)
12454         enddo
12455       enddo
12456 !******************************************************************************
12457 !
12458 !                              N O T E !!!
12459 !
12460 ! To save time, the factor of EXPON has been extracted from ALL components
12461 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12462 ! use!
12463 !
12464 !******************************************************************************
12465       return
12466       end subroutine elj_short
12467 !-----------------------------------------------------------------------------
12468       subroutine eljk_long(evdw)
12469 !
12470 ! This subroutine calculates the interaction energy of nonbonded side chains
12471 ! assuming the LJK potential of interaction.
12472 !
12473 !      implicit real*8 (a-h,o-z)
12474 !      include 'DIMENSIONS'
12475 !      include 'COMMON.GEO'
12476 !      include 'COMMON.VAR'
12477 !      include 'COMMON.LOCAL'
12478 !      include 'COMMON.CHAIN'
12479 !      include 'COMMON.DERIV'
12480 !      include 'COMMON.INTERACT'
12481 !      include 'COMMON.IOUNITS'
12482 !      include 'COMMON.NAMES'
12483       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12484       logical :: scheck
12485 !el local variables
12486       integer :: i,iint,j,k,itypi,itypi1,itypj
12487       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12488                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12489 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12490       evdw=0.0D0
12491       do i=iatsc_s,iatsc_e
12492         itypi=itype(i,1)
12493         if (itypi.eq.ntyp1) cycle
12494         itypi1=itype(i+1,1)
12495         xi=c(1,nres+i)
12496         yi=c(2,nres+i)
12497         zi=c(3,nres+i)
12498 !
12499 ! Calculate SC interaction energy.
12500 !
12501         do iint=1,nint_gr(i)
12502           do j=istart(i,iint),iend(i,iint)
12503             itypj=itype(j,1)
12504             if (itypj.eq.ntyp1) cycle
12505             xj=c(1,nres+j)-xi
12506             yj=c(2,nres+j)-yi
12507             zj=c(3,nres+j)-zi
12508             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12509             fac_augm=rrij**expon
12510             e_augm=augm(itypi,itypj)*fac_augm
12511             r_inv_ij=dsqrt(rrij)
12512             rij=1.0D0/r_inv_ij
12513             sss=sscale(rij/sigma(itypi,itypj))
12514             if (sss.lt.1.0d0) then
12515               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12516               fac=r_shift_inv**expon
12517               e1=fac*fac*aa_aq(itypi,itypj)
12518               e2=fac*bb_aq(itypi,itypj)
12519               evdwij=e_augm+e1+e2
12520 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12521 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12522 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12523 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12524 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12525 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12526 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12527               evdw=evdw+(1.0d0-sss)*evdwij
12528 !
12529 ! Calculate the components of the gradient in DC and X
12530 !
12531               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12532               fac=fac*(1.0d0-sss)
12533               gg(1)=xj*fac
12534               gg(2)=yj*fac
12535               gg(3)=zj*fac
12536               do k=1,3
12537                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12538                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12539                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12540                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12541               enddo
12542             endif
12543           enddo      ! j
12544         enddo        ! iint
12545       enddo          ! i
12546       do i=1,nct
12547         do j=1,3
12548           gvdwc(j,i)=expon*gvdwc(j,i)
12549           gvdwx(j,i)=expon*gvdwx(j,i)
12550         enddo
12551       enddo
12552       return
12553       end subroutine eljk_long
12554 !-----------------------------------------------------------------------------
12555       subroutine eljk_short(evdw)
12556 !
12557 ! This subroutine calculates the interaction energy of nonbonded side chains
12558 ! assuming the LJK potential of interaction.
12559 !
12560 !      implicit real*8 (a-h,o-z)
12561 !      include 'DIMENSIONS'
12562 !      include 'COMMON.GEO'
12563 !      include 'COMMON.VAR'
12564 !      include 'COMMON.LOCAL'
12565 !      include 'COMMON.CHAIN'
12566 !      include 'COMMON.DERIV'
12567 !      include 'COMMON.INTERACT'
12568 !      include 'COMMON.IOUNITS'
12569 !      include 'COMMON.NAMES'
12570       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12571       logical :: scheck
12572 !el local variables
12573       integer :: i,iint,j,k,itypi,itypi1,itypj
12574       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12575                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12576 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12577       evdw=0.0D0
12578       do i=iatsc_s,iatsc_e
12579         itypi=itype(i,1)
12580         if (itypi.eq.ntyp1) cycle
12581         itypi1=itype(i+1,1)
12582         xi=c(1,nres+i)
12583         yi=c(2,nres+i)
12584         zi=c(3,nres+i)
12585 !
12586 ! Calculate SC interaction energy.
12587 !
12588         do iint=1,nint_gr(i)
12589           do j=istart(i,iint),iend(i,iint)
12590             itypj=itype(j,1)
12591             if (itypj.eq.ntyp1) cycle
12592             xj=c(1,nres+j)-xi
12593             yj=c(2,nres+j)-yi
12594             zj=c(3,nres+j)-zi
12595             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12596             fac_augm=rrij**expon
12597             e_augm=augm(itypi,itypj)*fac_augm
12598             r_inv_ij=dsqrt(rrij)
12599             rij=1.0D0/r_inv_ij
12600             sss=sscale(rij/sigma(itypi,itypj))
12601             if (sss.gt.0.0d0) then
12602               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12603               fac=r_shift_inv**expon
12604               e1=fac*fac*aa_aq(itypi,itypj)
12605               e2=fac*bb_aq(itypi,itypj)
12606               evdwij=e_augm+e1+e2
12607 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12608 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12609 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12610 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12611 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12612 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12613 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12614               evdw=evdw+sss*evdwij
12615 !
12616 ! Calculate the components of the gradient in DC and X
12617 !
12618               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12619               fac=fac*sss
12620               gg(1)=xj*fac
12621               gg(2)=yj*fac
12622               gg(3)=zj*fac
12623               do k=1,3
12624                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12625                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12626                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12627                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12628               enddo
12629             endif
12630           enddo      ! j
12631         enddo        ! iint
12632       enddo          ! i
12633       do i=1,nct
12634         do j=1,3
12635           gvdwc(j,i)=expon*gvdwc(j,i)
12636           gvdwx(j,i)=expon*gvdwx(j,i)
12637         enddo
12638       enddo
12639       return
12640       end subroutine eljk_short
12641 !-----------------------------------------------------------------------------
12642       subroutine ebp_long(evdw)
12643 !
12644 ! This subroutine calculates the interaction energy of nonbonded side chains
12645 ! assuming the Berne-Pechukas potential of interaction.
12646 !
12647       use calc_data
12648 !      implicit real*8 (a-h,o-z)
12649 !      include 'DIMENSIONS'
12650 !      include 'COMMON.GEO'
12651 !      include 'COMMON.VAR'
12652 !      include 'COMMON.LOCAL'
12653 !      include 'COMMON.CHAIN'
12654 !      include 'COMMON.DERIV'
12655 !      include 'COMMON.NAMES'
12656 !      include 'COMMON.INTERACT'
12657 !      include 'COMMON.IOUNITS'
12658 !      include 'COMMON.CALC'
12659       use comm_srutu
12660 !el      integer :: icall
12661 !el      common /srutu/ icall
12662 !     double precision rrsave(maxdim)
12663       logical :: lprn
12664 !el local variables
12665       integer :: iint,itypi,itypi1,itypj
12666       real(kind=8) :: rrij,xi,yi,zi,fac
12667       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12668       evdw=0.0D0
12669 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12670       evdw=0.0D0
12671 !     if (icall.eq.0) then
12672 !       lprn=.true.
12673 !     else
12674         lprn=.false.
12675 !     endif
12676 !el      ind=0
12677       do i=iatsc_s,iatsc_e
12678         itypi=itype(i,1)
12679         if (itypi.eq.ntyp1) cycle
12680         itypi1=itype(i+1,1)
12681         xi=c(1,nres+i)
12682         yi=c(2,nres+i)
12683         zi=c(3,nres+i)
12684         dxi=dc_norm(1,nres+i)
12685         dyi=dc_norm(2,nres+i)
12686         dzi=dc_norm(3,nres+i)
12687 !        dsci_inv=dsc_inv(itypi)
12688         dsci_inv=vbld_inv(i+nres)
12689 !
12690 ! Calculate SC interaction energy.
12691 !
12692         do iint=1,nint_gr(i)
12693           do j=istart(i,iint),iend(i,iint)
12694 !el            ind=ind+1
12695             itypj=itype(j,1)
12696             if (itypj.eq.ntyp1) cycle
12697 !            dscj_inv=dsc_inv(itypj)
12698             dscj_inv=vbld_inv(j+nres)
12699             chi1=chi(itypi,itypj)
12700             chi2=chi(itypj,itypi)
12701             chi12=chi1*chi2
12702             chip1=chip(itypi)
12703             chip2=chip(itypj)
12704             chip12=chip1*chip2
12705             alf1=alp(itypi)
12706             alf2=alp(itypj)
12707             alf12=0.5D0*(alf1+alf2)
12708             xj=c(1,nres+j)-xi
12709             yj=c(2,nres+j)-yi
12710             zj=c(3,nres+j)-zi
12711             dxj=dc_norm(1,nres+j)
12712             dyj=dc_norm(2,nres+j)
12713             dzj=dc_norm(3,nres+j)
12714             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12715             rij=dsqrt(rrij)
12716             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12717
12718             if (sss.lt.1.0d0) then
12719
12720 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12721               call sc_angular
12722 ! Calculate whole angle-dependent part of epsilon and contributions
12723 ! to its derivatives
12724               fac=(rrij*sigsq)**expon2
12725               e1=fac*fac*aa_aq(itypi,itypj)
12726               e2=fac*bb_aq(itypi,itypj)
12727               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12728               eps2der=evdwij*eps3rt
12729               eps3der=evdwij*eps2rt
12730               evdwij=evdwij*eps2rt*eps3rt
12731               evdw=evdw+evdwij*(1.0d0-sss)
12732               if (lprn) then
12733               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12734               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12735 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12736 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12737 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12738 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12739 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12740 !d     &          evdwij
12741               endif
12742 ! Calculate gradient components.
12743               e1=e1*eps1*eps2rt**2*eps3rt**2
12744               fac=-expon*(e1+evdwij)
12745               sigder=fac/sigsq
12746               fac=rrij*fac
12747 ! Calculate radial part of the gradient
12748               gg(1)=xj*fac
12749               gg(2)=yj*fac
12750               gg(3)=zj*fac
12751 ! Calculate the angular part of the gradient and sum add the contributions
12752 ! to the appropriate components of the Cartesian gradient.
12753               call sc_grad_scale(1.0d0-sss)
12754             endif
12755           enddo      ! j
12756         enddo        ! iint
12757       enddo          ! i
12758 !     stop
12759       return
12760       end subroutine ebp_long
12761 !-----------------------------------------------------------------------------
12762       subroutine ebp_short(evdw)
12763 !
12764 ! This subroutine calculates the interaction energy of nonbonded side chains
12765 ! assuming the Berne-Pechukas potential of interaction.
12766 !
12767       use calc_data
12768 !      implicit real*8 (a-h,o-z)
12769 !      include 'DIMENSIONS'
12770 !      include 'COMMON.GEO'
12771 !      include 'COMMON.VAR'
12772 !      include 'COMMON.LOCAL'
12773 !      include 'COMMON.CHAIN'
12774 !      include 'COMMON.DERIV'
12775 !      include 'COMMON.NAMES'
12776 !      include 'COMMON.INTERACT'
12777 !      include 'COMMON.IOUNITS'
12778 !      include 'COMMON.CALC'
12779       use comm_srutu
12780 !el      integer :: icall
12781 !el      common /srutu/ icall
12782 !     double precision rrsave(maxdim)
12783       logical :: lprn
12784 !el local variables
12785       integer :: iint,itypi,itypi1,itypj
12786       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12787       real(kind=8) :: sss,e1,e2,evdw
12788       evdw=0.0D0
12789 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12790       evdw=0.0D0
12791 !     if (icall.eq.0) then
12792 !       lprn=.true.
12793 !     else
12794         lprn=.false.
12795 !     endif
12796 !el      ind=0
12797       do i=iatsc_s,iatsc_e
12798         itypi=itype(i,1)
12799         if (itypi.eq.ntyp1) cycle
12800         itypi1=itype(i+1,1)
12801         xi=c(1,nres+i)
12802         yi=c(2,nres+i)
12803         zi=c(3,nres+i)
12804         dxi=dc_norm(1,nres+i)
12805         dyi=dc_norm(2,nres+i)
12806         dzi=dc_norm(3,nres+i)
12807 !        dsci_inv=dsc_inv(itypi)
12808         dsci_inv=vbld_inv(i+nres)
12809 !
12810 ! Calculate SC interaction energy.
12811 !
12812         do iint=1,nint_gr(i)
12813           do j=istart(i,iint),iend(i,iint)
12814 !el            ind=ind+1
12815             itypj=itype(j,1)
12816             if (itypj.eq.ntyp1) cycle
12817 !            dscj_inv=dsc_inv(itypj)
12818             dscj_inv=vbld_inv(j+nres)
12819             chi1=chi(itypi,itypj)
12820             chi2=chi(itypj,itypi)
12821             chi12=chi1*chi2
12822             chip1=chip(itypi)
12823             chip2=chip(itypj)
12824             chip12=chip1*chip2
12825             alf1=alp(itypi)
12826             alf2=alp(itypj)
12827             alf12=0.5D0*(alf1+alf2)
12828             xj=c(1,nres+j)-xi
12829             yj=c(2,nres+j)-yi
12830             zj=c(3,nres+j)-zi
12831             dxj=dc_norm(1,nres+j)
12832             dyj=dc_norm(2,nres+j)
12833             dzj=dc_norm(3,nres+j)
12834             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12835             rij=dsqrt(rrij)
12836             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12837
12838             if (sss.gt.0.0d0) then
12839
12840 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12841               call sc_angular
12842 ! Calculate whole angle-dependent part of epsilon and contributions
12843 ! to its derivatives
12844               fac=(rrij*sigsq)**expon2
12845               e1=fac*fac*aa_aq(itypi,itypj)
12846               e2=fac*bb_aq(itypi,itypj)
12847               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12848               eps2der=evdwij*eps3rt
12849               eps3der=evdwij*eps2rt
12850               evdwij=evdwij*eps2rt*eps3rt
12851               evdw=evdw+evdwij*sss
12852               if (lprn) then
12853               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12854               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12855 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12856 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12857 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12858 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12859 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12860 !d     &          evdwij
12861               endif
12862 ! Calculate gradient components.
12863               e1=e1*eps1*eps2rt**2*eps3rt**2
12864               fac=-expon*(e1+evdwij)
12865               sigder=fac/sigsq
12866               fac=rrij*fac
12867 ! Calculate radial part of the gradient
12868               gg(1)=xj*fac
12869               gg(2)=yj*fac
12870               gg(3)=zj*fac
12871 ! Calculate the angular part of the gradient and sum add the contributions
12872 ! to the appropriate components of the Cartesian gradient.
12873               call sc_grad_scale(sss)
12874             endif
12875           enddo      ! j
12876         enddo        ! iint
12877       enddo          ! i
12878 !     stop
12879       return
12880       end subroutine ebp_short
12881 !-----------------------------------------------------------------------------
12882       subroutine egb_long(evdw)
12883 !
12884 ! This subroutine calculates the interaction energy of nonbonded side chains
12885 ! assuming the Gay-Berne potential of interaction.
12886 !
12887       use calc_data
12888 !      implicit real*8 (a-h,o-z)
12889 !      include 'DIMENSIONS'
12890 !      include 'COMMON.GEO'
12891 !      include 'COMMON.VAR'
12892 !      include 'COMMON.LOCAL'
12893 !      include 'COMMON.CHAIN'
12894 !      include 'COMMON.DERIV'
12895 !      include 'COMMON.NAMES'
12896 !      include 'COMMON.INTERACT'
12897 !      include 'COMMON.IOUNITS'
12898 !      include 'COMMON.CALC'
12899 !      include 'COMMON.CONTROL'
12900       logical :: lprn
12901 !el local variables
12902       integer :: iint,itypi,itypi1,itypj,subchap
12903       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
12904       real(kind=8) :: sss,e1,e2,evdw,sss_grad
12905       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
12906                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
12907                     ssgradlipi,ssgradlipj
12908
12909
12910       evdw=0.0D0
12911 !cccc      energy_dec=.false.
12912 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12913       evdw=0.0D0
12914       lprn=.false.
12915 !     if (icall.eq.0) lprn=.false.
12916 !el      ind=0
12917       do i=iatsc_s,iatsc_e
12918         itypi=itype(i,1)
12919         if (itypi.eq.ntyp1) cycle
12920         itypi1=itype(i+1,1)
12921         xi=c(1,nres+i)
12922         yi=c(2,nres+i)
12923         zi=c(3,nres+i)
12924           xi=mod(xi,boxxsize)
12925           if (xi.lt.0) xi=xi+boxxsize
12926           yi=mod(yi,boxysize)
12927           if (yi.lt.0) yi=yi+boxysize
12928           zi=mod(zi,boxzsize)
12929           if (zi.lt.0) zi=zi+boxzsize
12930        if ((zi.gt.bordlipbot)    &
12931         .and.(zi.lt.bordliptop)) then
12932 !C the energy transfer exist
12933         if (zi.lt.buflipbot) then
12934 !C what fraction I am in
12935          fracinbuf=1.0d0-    &
12936              ((zi-bordlipbot)/lipbufthick)
12937 !C lipbufthick is thickenes of lipid buffore
12938          sslipi=sscalelip(fracinbuf)
12939          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
12940         elseif (zi.gt.bufliptop) then
12941          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
12942          sslipi=sscalelip(fracinbuf)
12943          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
12944         else
12945          sslipi=1.0d0
12946          ssgradlipi=0.0
12947         endif
12948        else
12949          sslipi=0.0d0
12950          ssgradlipi=0.0
12951        endif
12952
12953         dxi=dc_norm(1,nres+i)
12954         dyi=dc_norm(2,nres+i)
12955         dzi=dc_norm(3,nres+i)
12956 !        dsci_inv=dsc_inv(itypi)
12957         dsci_inv=vbld_inv(i+nres)
12958 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
12959 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
12960 !
12961 ! Calculate SC interaction energy.
12962 !
12963         do iint=1,nint_gr(i)
12964           do j=istart(i,iint),iend(i,iint)
12965             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
12966 !              call dyn_ssbond_ene(i,j,evdwij)
12967 !              evdw=evdw+evdwij
12968 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12969 !                              'evdw',i,j,evdwij,' ss'
12970 !              if (energy_dec) write (iout,*) &
12971 !                              'evdw',i,j,evdwij,' ss'
12972 !             do k=j+1,iend(i,iint)
12973 !C search over all next residues
12974 !              if (dyn_ss_mask(k)) then
12975 !C check if they are cysteins
12976 !C              write(iout,*) 'k=',k
12977
12978 !c              write(iout,*) "PRZED TRI", evdwij
12979 !               evdwij_przed_tri=evdwij
12980 !              call triple_ssbond_ene(i,j,k,evdwij)
12981 !c               if(evdwij_przed_tri.ne.evdwij) then
12982 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
12983 !c               endif
12984
12985 !c              write(iout,*) "PO TRI", evdwij
12986 !C call the energy function that removes the artifical triple disulfide
12987 !C bond the soubroutine is located in ssMD.F
12988 !              evdw=evdw+evdwij
12989               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12990                             'evdw',i,j,evdwij,'tss'
12991 !              endif!dyn_ss_mask(k)
12992 !             enddo! k
12993
12994             ELSE
12995 !el            ind=ind+1
12996             itypj=itype(j,1)
12997             if (itypj.eq.ntyp1) cycle
12998 !            dscj_inv=dsc_inv(itypj)
12999             dscj_inv=vbld_inv(j+nres)
13000 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13001 !     &       1.0d0/vbld(j+nres)
13002 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13003             sig0ij=sigma(itypi,itypj)
13004             chi1=chi(itypi,itypj)
13005             chi2=chi(itypj,itypi)
13006             chi12=chi1*chi2
13007             chip1=chip(itypi)
13008             chip2=chip(itypj)
13009             chip12=chip1*chip2
13010             alf1=alp(itypi)
13011             alf2=alp(itypj)
13012             alf12=0.5D0*(alf1+alf2)
13013             xj=c(1,nres+j)
13014             yj=c(2,nres+j)
13015             zj=c(3,nres+j)
13016 ! Searching for nearest neighbour
13017           xj=mod(xj,boxxsize)
13018           if (xj.lt.0) xj=xj+boxxsize
13019           yj=mod(yj,boxysize)
13020           if (yj.lt.0) yj=yj+boxysize
13021           zj=mod(zj,boxzsize)
13022           if (zj.lt.0) zj=zj+boxzsize
13023        if ((zj.gt.bordlipbot)   &
13024       .and.(zj.lt.bordliptop)) then
13025 !C the energy transfer exist
13026         if (zj.lt.buflipbot) then
13027 !C what fraction I am in
13028          fracinbuf=1.0d0-  &
13029              ((zj-bordlipbot)/lipbufthick)
13030 !C lipbufthick is thickenes of lipid buffore
13031          sslipj=sscalelip(fracinbuf)
13032          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13033         elseif (zj.gt.bufliptop) then
13034          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13035          sslipj=sscalelip(fracinbuf)
13036          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13037         else
13038          sslipj=1.0d0
13039          ssgradlipj=0.0
13040         endif
13041        else
13042          sslipj=0.0d0
13043          ssgradlipj=0.0
13044        endif
13045       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13046        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13047       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13048        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13049
13050           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13051           xj_safe=xj
13052           yj_safe=yj
13053           zj_safe=zj
13054           subchap=0
13055           do xshift=-1,1
13056           do yshift=-1,1
13057           do zshift=-1,1
13058           xj=xj_safe+xshift*boxxsize
13059           yj=yj_safe+yshift*boxysize
13060           zj=zj_safe+zshift*boxzsize
13061           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13062           if(dist_temp.lt.dist_init) then
13063             dist_init=dist_temp
13064             xj_temp=xj
13065             yj_temp=yj
13066             zj_temp=zj
13067             subchap=1
13068           endif
13069           enddo
13070           enddo
13071           enddo
13072           if (subchap.eq.1) then
13073           xj=xj_temp-xi
13074           yj=yj_temp-yi
13075           zj=zj_temp-zi
13076           else
13077           xj=xj_safe-xi
13078           yj=yj_safe-yi
13079           zj=zj_safe-zi
13080           endif
13081
13082             dxj=dc_norm(1,nres+j)
13083             dyj=dc_norm(2,nres+j)
13084             dzj=dc_norm(3,nres+j)
13085             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13086             rij=dsqrt(rrij)
13087             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13088             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13089             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13090             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13091             if (sss_ele_cut.le.0.0) cycle
13092             if (sss.lt.1.0d0) then
13093
13094 ! Calculate angle-dependent terms of energy and contributions to their
13095 ! derivatives.
13096               call sc_angular
13097               sigsq=1.0D0/sigsq
13098               sig=sig0ij*dsqrt(sigsq)
13099               rij_shift=1.0D0/rij-sig+sig0ij
13100 ! for diagnostics; uncomment
13101 !              rij_shift=1.2*sig0ij
13102 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13103               if (rij_shift.le.0.0D0) then
13104                 evdw=1.0D20
13105 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13106 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13107 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13108                 return
13109               endif
13110               sigder=-sig*sigsq
13111 !---------------------------------------------------------------
13112               rij_shift=1.0D0/rij_shift
13113               fac=rij_shift**expon
13114               e1=fac*fac*aa
13115               e2=fac*bb
13116               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13117               eps2der=evdwij*eps3rt
13118               eps3der=evdwij*eps2rt
13119 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13120 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13121               evdwij=evdwij*eps2rt*eps3rt
13122               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13123               if (lprn) then
13124               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13125               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13126               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13127                 restyp(itypi,1),i,restyp(itypj,1),j,&
13128                 epsi,sigm,chi1,chi2,chip1,chip2,&
13129                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13130                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13131                 evdwij
13132               endif
13133
13134               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13135                               'evdw',i,j,evdwij
13136 !              if (energy_dec) write (iout,*) &
13137 !                              'evdw',i,j,evdwij,"egb_long"
13138
13139 ! Calculate gradient components.
13140               e1=e1*eps1*eps2rt**2*eps3rt**2
13141               fac=-expon*(e1+evdwij)*rij_shift
13142               sigder=fac*sigder
13143               fac=rij*fac
13144               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13145             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13146             /sigmaii(itypi,itypj))
13147 !              fac=0.0d0
13148 ! Calculate the radial part of the gradient
13149               gg(1)=xj*fac
13150               gg(2)=yj*fac
13151               gg(3)=zj*fac
13152 ! Calculate angular part of the gradient.
13153               call sc_grad_scale(1.0d0-sss)
13154             ENDIF    !mask_dyn_ss
13155             endif
13156           enddo      ! j
13157         enddo        ! iint
13158       enddo          ! i
13159 !      write (iout,*) "Number of loop steps in EGB:",ind
13160 !ccc      energy_dec=.false.
13161       return
13162       end subroutine egb_long
13163 !-----------------------------------------------------------------------------
13164       subroutine egb_short(evdw)
13165 !
13166 ! This subroutine calculates the interaction energy of nonbonded side chains
13167 ! assuming the Gay-Berne potential of interaction.
13168 !
13169       use calc_data
13170 !      implicit real*8 (a-h,o-z)
13171 !      include 'DIMENSIONS'
13172 !      include 'COMMON.GEO'
13173 !      include 'COMMON.VAR'
13174 !      include 'COMMON.LOCAL'
13175 !      include 'COMMON.CHAIN'
13176 !      include 'COMMON.DERIV'
13177 !      include 'COMMON.NAMES'
13178 !      include 'COMMON.INTERACT'
13179 !      include 'COMMON.IOUNITS'
13180 !      include 'COMMON.CALC'
13181 !      include 'COMMON.CONTROL'
13182       logical :: lprn
13183 !el local variables
13184       integer :: iint,itypi,itypi1,itypj,subchap
13185       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13186       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13187       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13188                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13189                     ssgradlipi,ssgradlipj
13190       evdw=0.0D0
13191 !cccc      energy_dec=.false.
13192 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13193       evdw=0.0D0
13194       lprn=.false.
13195 !     if (icall.eq.0) lprn=.false.
13196 !el      ind=0
13197       do i=iatsc_s,iatsc_e
13198         itypi=itype(i,1)
13199         if (itypi.eq.ntyp1) cycle
13200         itypi1=itype(i+1,1)
13201         xi=c(1,nres+i)
13202         yi=c(2,nres+i)
13203         zi=c(3,nres+i)
13204           xi=mod(xi,boxxsize)
13205           if (xi.lt.0) xi=xi+boxxsize
13206           yi=mod(yi,boxysize)
13207           if (yi.lt.0) yi=yi+boxysize
13208           zi=mod(zi,boxzsize)
13209           if (zi.lt.0) zi=zi+boxzsize
13210        if ((zi.gt.bordlipbot)    &
13211         .and.(zi.lt.bordliptop)) then
13212 !C the energy transfer exist
13213         if (zi.lt.buflipbot) then
13214 !C what fraction I am in
13215          fracinbuf=1.0d0-    &
13216              ((zi-bordlipbot)/lipbufthick)
13217 !C lipbufthick is thickenes of lipid buffore
13218          sslipi=sscalelip(fracinbuf)
13219          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13220         elseif (zi.gt.bufliptop) then
13221          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13222          sslipi=sscalelip(fracinbuf)
13223          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13224         else
13225          sslipi=1.0d0
13226          ssgradlipi=0.0
13227         endif
13228        else
13229          sslipi=0.0d0
13230          ssgradlipi=0.0
13231        endif
13232
13233         dxi=dc_norm(1,nres+i)
13234         dyi=dc_norm(2,nres+i)
13235         dzi=dc_norm(3,nres+i)
13236 !        dsci_inv=dsc_inv(itypi)
13237         dsci_inv=vbld_inv(i+nres)
13238
13239         dxi=dc_norm(1,nres+i)
13240         dyi=dc_norm(2,nres+i)
13241         dzi=dc_norm(3,nres+i)
13242 !        dsci_inv=dsc_inv(itypi)
13243         dsci_inv=vbld_inv(i+nres)
13244 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13245 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13246 !
13247 ! Calculate SC interaction energy.
13248 !
13249         do iint=1,nint_gr(i)
13250           do j=istart(i,iint),iend(i,iint)
13251             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13252               call dyn_ssbond_ene(i,j,evdwij)
13253               evdw=evdw+evdwij
13254               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13255                               'evdw',i,j,evdwij,' ss'
13256              do k=j+1,iend(i,iint)
13257 !C search over all next residues
13258               if (dyn_ss_mask(k)) then
13259 !C check if they are cysteins
13260 !C              write(iout,*) 'k=',k
13261
13262 !c              write(iout,*) "PRZED TRI", evdwij
13263 !               evdwij_przed_tri=evdwij
13264               call triple_ssbond_ene(i,j,k,evdwij)
13265 !c               if(evdwij_przed_tri.ne.evdwij) then
13266 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13267 !c               endif
13268
13269 !c              write(iout,*) "PO TRI", evdwij
13270 !C call the energy function that removes the artifical triple disulfide
13271 !C bond the soubroutine is located in ssMD.F
13272               evdw=evdw+evdwij
13273               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13274                             'evdw',i,j,evdwij,'tss'
13275               endif!dyn_ss_mask(k)
13276              enddo! k
13277
13278 !              if (energy_dec) write (iout,*) &
13279 !                              'evdw',i,j,evdwij,' ss'
13280             ELSE
13281 !el            ind=ind+1
13282             itypj=itype(j,1)
13283             if (itypj.eq.ntyp1) cycle
13284 !            dscj_inv=dsc_inv(itypj)
13285             dscj_inv=vbld_inv(j+nres)
13286 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13287 !     &       1.0d0/vbld(j+nres)
13288 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13289             sig0ij=sigma(itypi,itypj)
13290             chi1=chi(itypi,itypj)
13291             chi2=chi(itypj,itypi)
13292             chi12=chi1*chi2
13293             chip1=chip(itypi)
13294             chip2=chip(itypj)
13295             chip12=chip1*chip2
13296             alf1=alp(itypi)
13297             alf2=alp(itypj)
13298             alf12=0.5D0*(alf1+alf2)
13299 !            xj=c(1,nres+j)-xi
13300 !            yj=c(2,nres+j)-yi
13301 !            zj=c(3,nres+j)-zi
13302             xj=c(1,nres+j)
13303             yj=c(2,nres+j)
13304             zj=c(3,nres+j)
13305 ! Searching for nearest neighbour
13306           xj=mod(xj,boxxsize)
13307           if (xj.lt.0) xj=xj+boxxsize
13308           yj=mod(yj,boxysize)
13309           if (yj.lt.0) yj=yj+boxysize
13310           zj=mod(zj,boxzsize)
13311           if (zj.lt.0) zj=zj+boxzsize
13312        if ((zj.gt.bordlipbot)   &
13313       .and.(zj.lt.bordliptop)) then
13314 !C the energy transfer exist
13315         if (zj.lt.buflipbot) then
13316 !C what fraction I am in
13317          fracinbuf=1.0d0-  &
13318              ((zj-bordlipbot)/lipbufthick)
13319 !C lipbufthick is thickenes of lipid buffore
13320          sslipj=sscalelip(fracinbuf)
13321          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13322         elseif (zj.gt.bufliptop) then
13323          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13324          sslipj=sscalelip(fracinbuf)
13325          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13326         else
13327          sslipj=1.0d0
13328          ssgradlipj=0.0
13329         endif
13330        else
13331          sslipj=0.0d0
13332          ssgradlipj=0.0
13333        endif
13334       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13335        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13336       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13337        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13338
13339           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13340           xj_safe=xj
13341           yj_safe=yj
13342           zj_safe=zj
13343           subchap=0
13344
13345           do xshift=-1,1
13346           do yshift=-1,1
13347           do zshift=-1,1
13348           xj=xj_safe+xshift*boxxsize
13349           yj=yj_safe+yshift*boxysize
13350           zj=zj_safe+zshift*boxzsize
13351           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13352           if(dist_temp.lt.dist_init) then
13353             dist_init=dist_temp
13354             xj_temp=xj
13355             yj_temp=yj
13356             zj_temp=zj
13357             subchap=1
13358           endif
13359           enddo
13360           enddo
13361           enddo
13362           if (subchap.eq.1) then
13363           xj=xj_temp-xi
13364           yj=yj_temp-yi
13365           zj=zj_temp-zi
13366           else
13367           xj=xj_safe-xi
13368           yj=yj_safe-yi
13369           zj=zj_safe-zi
13370           endif
13371
13372             dxj=dc_norm(1,nres+j)
13373             dyj=dc_norm(2,nres+j)
13374             dzj=dc_norm(3,nres+j)
13375             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13376             rij=dsqrt(rrij)
13377             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13378             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13379             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13380             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13381             if (sss_ele_cut.le.0.0) cycle
13382
13383             if (sss.gt.0.0d0) then
13384
13385 ! Calculate angle-dependent terms of energy and contributions to their
13386 ! derivatives.
13387               call sc_angular
13388               sigsq=1.0D0/sigsq
13389               sig=sig0ij*dsqrt(sigsq)
13390               rij_shift=1.0D0/rij-sig+sig0ij
13391 ! for diagnostics; uncomment
13392 !              rij_shift=1.2*sig0ij
13393 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13394               if (rij_shift.le.0.0D0) then
13395                 evdw=1.0D20
13396 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13397 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13398 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13399                 return
13400               endif
13401               sigder=-sig*sigsq
13402 !---------------------------------------------------------------
13403               rij_shift=1.0D0/rij_shift
13404               fac=rij_shift**expon
13405               e1=fac*fac*aa
13406               e2=fac*bb
13407               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13408               eps2der=evdwij*eps3rt
13409               eps3der=evdwij*eps2rt
13410 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13411 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13412               evdwij=evdwij*eps2rt*eps3rt
13413               evdw=evdw+evdwij*sss*sss_ele_cut
13414               if (lprn) then
13415               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13416               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13417               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13418                 restyp(itypi,1),i,restyp(itypj,1),j,&
13419                 epsi,sigm,chi1,chi2,chip1,chip2,&
13420                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13421                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13422                 evdwij
13423               endif
13424
13425               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13426                               'evdw',i,j,evdwij
13427 !              if (energy_dec) write (iout,*) &
13428 !                              'evdw',i,j,evdwij,"egb_short"
13429
13430 ! Calculate gradient components.
13431               e1=e1*eps1*eps2rt**2*eps3rt**2
13432               fac=-expon*(e1+evdwij)*rij_shift
13433               sigder=fac*sigder
13434               fac=rij*fac
13435               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13436             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13437             /sigmaii(itypi,itypj))
13438
13439 !              fac=0.0d0
13440 ! Calculate the radial part of the gradient
13441               gg(1)=xj*fac
13442               gg(2)=yj*fac
13443               gg(3)=zj*fac
13444 ! Calculate angular part of the gradient.
13445               call sc_grad_scale(sss)
13446             endif
13447           ENDIF !mask_dyn_ss
13448           enddo      ! j
13449         enddo        ! iint
13450       enddo          ! i
13451 !      write (iout,*) "Number of loop steps in EGB:",ind
13452 !ccc      energy_dec=.false.
13453       return
13454       end subroutine egb_short
13455 !-----------------------------------------------------------------------------
13456       subroutine egbv_long(evdw)
13457 !
13458 ! This subroutine calculates the interaction energy of nonbonded side chains
13459 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13460 !
13461       use calc_data
13462 !      implicit real*8 (a-h,o-z)
13463 !      include 'DIMENSIONS'
13464 !      include 'COMMON.GEO'
13465 !      include 'COMMON.VAR'
13466 !      include 'COMMON.LOCAL'
13467 !      include 'COMMON.CHAIN'
13468 !      include 'COMMON.DERIV'
13469 !      include 'COMMON.NAMES'
13470 !      include 'COMMON.INTERACT'
13471 !      include 'COMMON.IOUNITS'
13472 !      include 'COMMON.CALC'
13473       use comm_srutu
13474 !el      integer :: icall
13475 !el      common /srutu/ icall
13476       logical :: lprn
13477 !el local variables
13478       integer :: iint,itypi,itypi1,itypj
13479       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13480       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13481       evdw=0.0D0
13482 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13483       evdw=0.0D0
13484       lprn=.false.
13485 !     if (icall.eq.0) lprn=.true.
13486 !el      ind=0
13487       do i=iatsc_s,iatsc_e
13488         itypi=itype(i,1)
13489         if (itypi.eq.ntyp1) cycle
13490         itypi1=itype(i+1,1)
13491         xi=c(1,nres+i)
13492         yi=c(2,nres+i)
13493         zi=c(3,nres+i)
13494         dxi=dc_norm(1,nres+i)
13495         dyi=dc_norm(2,nres+i)
13496         dzi=dc_norm(3,nres+i)
13497 !        dsci_inv=dsc_inv(itypi)
13498         dsci_inv=vbld_inv(i+nres)
13499 !
13500 ! Calculate SC interaction energy.
13501 !
13502         do iint=1,nint_gr(i)
13503           do j=istart(i,iint),iend(i,iint)
13504 !el            ind=ind+1
13505             itypj=itype(j,1)
13506             if (itypj.eq.ntyp1) cycle
13507 !            dscj_inv=dsc_inv(itypj)
13508             dscj_inv=vbld_inv(j+nres)
13509             sig0ij=sigma(itypi,itypj)
13510             r0ij=r0(itypi,itypj)
13511             chi1=chi(itypi,itypj)
13512             chi2=chi(itypj,itypi)
13513             chi12=chi1*chi2
13514             chip1=chip(itypi)
13515             chip2=chip(itypj)
13516             chip12=chip1*chip2
13517             alf1=alp(itypi)
13518             alf2=alp(itypj)
13519             alf12=0.5D0*(alf1+alf2)
13520             xj=c(1,nres+j)-xi
13521             yj=c(2,nres+j)-yi
13522             zj=c(3,nres+j)-zi
13523             dxj=dc_norm(1,nres+j)
13524             dyj=dc_norm(2,nres+j)
13525             dzj=dc_norm(3,nres+j)
13526             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13527             rij=dsqrt(rrij)
13528
13529             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13530
13531             if (sss.lt.1.0d0) then
13532
13533 ! Calculate angle-dependent terms of energy and contributions to their
13534 ! derivatives.
13535               call sc_angular
13536               sigsq=1.0D0/sigsq
13537               sig=sig0ij*dsqrt(sigsq)
13538               rij_shift=1.0D0/rij-sig+r0ij
13539 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13540               if (rij_shift.le.0.0D0) then
13541                 evdw=1.0D20
13542                 return
13543               endif
13544               sigder=-sig*sigsq
13545 !---------------------------------------------------------------
13546               rij_shift=1.0D0/rij_shift
13547               fac=rij_shift**expon
13548               e1=fac*fac*aa_aq(itypi,itypj)
13549               e2=fac*bb_aq(itypi,itypj)
13550               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13551               eps2der=evdwij*eps3rt
13552               eps3der=evdwij*eps2rt
13553               fac_augm=rrij**expon
13554               e_augm=augm(itypi,itypj)*fac_augm
13555               evdwij=evdwij*eps2rt*eps3rt
13556               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13557               if (lprn) then
13558               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13559               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13560               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13561                 restyp(itypi,1),i,restyp(itypj,1),j,&
13562                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13563                 chi1,chi2,chip1,chip2,&
13564                 eps1,eps2rt**2,eps3rt**2,&
13565                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13566                 evdwij+e_augm
13567               endif
13568 ! Calculate gradient components.
13569               e1=e1*eps1*eps2rt**2*eps3rt**2
13570               fac=-expon*(e1+evdwij)*rij_shift
13571               sigder=fac*sigder
13572               fac=rij*fac-2*expon*rrij*e_augm
13573 ! Calculate the radial part of the gradient
13574               gg(1)=xj*fac
13575               gg(2)=yj*fac
13576               gg(3)=zj*fac
13577 ! Calculate angular part of the gradient.
13578               call sc_grad_scale(1.0d0-sss)
13579             endif
13580           enddo      ! j
13581         enddo        ! iint
13582       enddo          ! i
13583       end subroutine egbv_long
13584 !-----------------------------------------------------------------------------
13585       subroutine egbv_short(evdw)
13586 !
13587 ! This subroutine calculates the interaction energy of nonbonded side chains
13588 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13589 !
13590       use calc_data
13591 !      implicit real*8 (a-h,o-z)
13592 !      include 'DIMENSIONS'
13593 !      include 'COMMON.GEO'
13594 !      include 'COMMON.VAR'
13595 !      include 'COMMON.LOCAL'
13596 !      include 'COMMON.CHAIN'
13597 !      include 'COMMON.DERIV'
13598 !      include 'COMMON.NAMES'
13599 !      include 'COMMON.INTERACT'
13600 !      include 'COMMON.IOUNITS'
13601 !      include 'COMMON.CALC'
13602       use comm_srutu
13603 !el      integer :: icall
13604 !el      common /srutu/ icall
13605       logical :: lprn
13606 !el local variables
13607       integer :: iint,itypi,itypi1,itypj
13608       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13609       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13610       evdw=0.0D0
13611 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13612       evdw=0.0D0
13613       lprn=.false.
13614 !     if (icall.eq.0) lprn=.true.
13615 !el      ind=0
13616       do i=iatsc_s,iatsc_e
13617         itypi=itype(i,1)
13618         if (itypi.eq.ntyp1) cycle
13619         itypi1=itype(i+1,1)
13620         xi=c(1,nres+i)
13621         yi=c(2,nres+i)
13622         zi=c(3,nres+i)
13623         dxi=dc_norm(1,nres+i)
13624         dyi=dc_norm(2,nres+i)
13625         dzi=dc_norm(3,nres+i)
13626 !        dsci_inv=dsc_inv(itypi)
13627         dsci_inv=vbld_inv(i+nres)
13628 !
13629 ! Calculate SC interaction energy.
13630 !
13631         do iint=1,nint_gr(i)
13632           do j=istart(i,iint),iend(i,iint)
13633 !el            ind=ind+1
13634             itypj=itype(j,1)
13635             if (itypj.eq.ntyp1) cycle
13636 !            dscj_inv=dsc_inv(itypj)
13637             dscj_inv=vbld_inv(j+nres)
13638             sig0ij=sigma(itypi,itypj)
13639             r0ij=r0(itypi,itypj)
13640             chi1=chi(itypi,itypj)
13641             chi2=chi(itypj,itypi)
13642             chi12=chi1*chi2
13643             chip1=chip(itypi)
13644             chip2=chip(itypj)
13645             chip12=chip1*chip2
13646             alf1=alp(itypi)
13647             alf2=alp(itypj)
13648             alf12=0.5D0*(alf1+alf2)
13649             xj=c(1,nres+j)-xi
13650             yj=c(2,nres+j)-yi
13651             zj=c(3,nres+j)-zi
13652             dxj=dc_norm(1,nres+j)
13653             dyj=dc_norm(2,nres+j)
13654             dzj=dc_norm(3,nres+j)
13655             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13656             rij=dsqrt(rrij)
13657
13658             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13659
13660             if (sss.gt.0.0d0) then
13661
13662 ! Calculate angle-dependent terms of energy and contributions to their
13663 ! derivatives.
13664               call sc_angular
13665               sigsq=1.0D0/sigsq
13666               sig=sig0ij*dsqrt(sigsq)
13667               rij_shift=1.0D0/rij-sig+r0ij
13668 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13669               if (rij_shift.le.0.0D0) then
13670                 evdw=1.0D20
13671                 return
13672               endif
13673               sigder=-sig*sigsq
13674 !---------------------------------------------------------------
13675               rij_shift=1.0D0/rij_shift
13676               fac=rij_shift**expon
13677               e1=fac*fac*aa_aq(itypi,itypj)
13678               e2=fac*bb_aq(itypi,itypj)
13679               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13680               eps2der=evdwij*eps3rt
13681               eps3der=evdwij*eps2rt
13682               fac_augm=rrij**expon
13683               e_augm=augm(itypi,itypj)*fac_augm
13684               evdwij=evdwij*eps2rt*eps3rt
13685               evdw=evdw+(evdwij+e_augm)*sss
13686               if (lprn) then
13687               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13688               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13689               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13690                 restyp(itypi,1),i,restyp(itypj,1),j,&
13691                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13692                 chi1,chi2,chip1,chip2,&
13693                 eps1,eps2rt**2,eps3rt**2,&
13694                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13695                 evdwij+e_augm
13696               endif
13697 ! Calculate gradient components.
13698               e1=e1*eps1*eps2rt**2*eps3rt**2
13699               fac=-expon*(e1+evdwij)*rij_shift
13700               sigder=fac*sigder
13701               fac=rij*fac-2*expon*rrij*e_augm
13702 ! Calculate the radial part of the gradient
13703               gg(1)=xj*fac
13704               gg(2)=yj*fac
13705               gg(3)=zj*fac
13706 ! Calculate angular part of the gradient.
13707               call sc_grad_scale(sss)
13708             endif
13709           enddo      ! j
13710         enddo        ! iint
13711       enddo          ! i
13712       end subroutine egbv_short
13713 !-----------------------------------------------------------------------------
13714       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13715 !
13716 ! This subroutine calculates the average interaction energy and its gradient
13717 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13718 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13719 ! The potential depends both on the distance of peptide-group centers and on
13720 ! the orientation of the CA-CA virtual bonds.
13721 !
13722 !      implicit real*8 (a-h,o-z)
13723
13724       use comm_locel
13725 #ifdef MPI
13726       include 'mpif.h'
13727 #endif
13728 !      include 'DIMENSIONS'
13729 !      include 'COMMON.CONTROL'
13730 !      include 'COMMON.SETUP'
13731 !      include 'COMMON.IOUNITS'
13732 !      include 'COMMON.GEO'
13733 !      include 'COMMON.VAR'
13734 !      include 'COMMON.LOCAL'
13735 !      include 'COMMON.CHAIN'
13736 !      include 'COMMON.DERIV'
13737 !      include 'COMMON.INTERACT'
13738 !      include 'COMMON.CONTACTS'
13739 !      include 'COMMON.TORSION'
13740 !      include 'COMMON.VECTORS'
13741 !      include 'COMMON.FFIELD'
13742 !      include 'COMMON.TIME1'
13743       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13744       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13745       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13746 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13747       real(kind=8),dimension(4) :: muij
13748 !el      integer :: num_conti,j1,j2
13749 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13750 !el                   dz_normi,xmedi,ymedi,zmedi
13751 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13752 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13753 !el          num_conti,j1,j2
13754 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13755 #ifdef MOMENT
13756       real(kind=8) :: scal_el=1.0d0
13757 #else
13758       real(kind=8) :: scal_el=0.5d0
13759 #endif
13760 ! 12/13/98
13761 ! 13-go grudnia roku pamietnego...
13762       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13763                                              0.0d0,1.0d0,0.0d0,&
13764                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13765 !el local variables
13766       integer :: i,j,k
13767       real(kind=8) :: fac
13768       real(kind=8) :: dxj,dyj,dzj
13769       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13770
13771 !      allocate(num_cont_hb(nres)) !(maxres)
13772 !d      write(iout,*) 'In EELEC'
13773 !d      do i=1,nloctyp
13774 !d        write(iout,*) 'Type',i
13775 !d        write(iout,*) 'B1',B1(:,i)
13776 !d        write(iout,*) 'B2',B2(:,i)
13777 !d        write(iout,*) 'CC',CC(:,:,i)
13778 !d        write(iout,*) 'DD',DD(:,:,i)
13779 !d        write(iout,*) 'EE',EE(:,:,i)
13780 !d      enddo
13781 !d      call check_vecgrad
13782 !d      stop
13783       if (icheckgrad.eq.1) then
13784         do i=1,nres-1
13785           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13786           do k=1,3
13787             dc_norm(k,i)=dc(k,i)*fac
13788           enddo
13789 !          write (iout,*) 'i',i,' fac',fac
13790         enddo
13791       endif
13792       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13793           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13794           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13795 !        call vec_and_deriv
13796 #ifdef TIMING
13797         time01=MPI_Wtime()
13798 #endif
13799 !        print *, "before set matrices"
13800         call set_matrices
13801 !        print *,"after set martices"
13802 #ifdef TIMING
13803         time_mat=time_mat+MPI_Wtime()-time01
13804 #endif
13805       endif
13806 !d      do i=1,nres-1
13807 !d        write (iout,*) 'i=',i
13808 !d        do k=1,3
13809 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
13810 !d        enddo
13811 !d        do k=1,3
13812 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
13813 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
13814 !d        enddo
13815 !d      enddo
13816       t_eelecij=0.0d0
13817       ees=0.0D0
13818       evdw1=0.0D0
13819       eel_loc=0.0d0
13820       eello_turn3=0.0d0
13821       eello_turn4=0.0d0
13822 !el      ind=0
13823       do i=1,nres
13824         num_cont_hb(i)=0
13825       enddo
13826 !d      print '(a)','Enter EELEC'
13827 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
13828 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13829 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13830       do i=1,nres
13831         gel_loc_loc(i)=0.0d0
13832         gcorr_loc(i)=0.0d0
13833       enddo
13834 !
13835 !
13836 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
13837 !
13838 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
13839 !
13840       do i=iturn3_start,iturn3_end
13841         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
13842         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
13843         dxi=dc(1,i)
13844         dyi=dc(2,i)
13845         dzi=dc(3,i)
13846         dx_normi=dc_norm(1,i)
13847         dy_normi=dc_norm(2,i)
13848         dz_normi=dc_norm(3,i)
13849         xmedi=c(1,i)+0.5d0*dxi
13850         ymedi=c(2,i)+0.5d0*dyi
13851         zmedi=c(3,i)+0.5d0*dzi
13852           xmedi=dmod(xmedi,boxxsize)
13853           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13854           ymedi=dmod(ymedi,boxysize)
13855           if (ymedi.lt.0) ymedi=ymedi+boxysize
13856           zmedi=dmod(zmedi,boxzsize)
13857           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13858         num_conti=0
13859         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
13860         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
13861         num_cont_hb(i)=num_conti
13862       enddo
13863       do i=iturn4_start,iturn4_end
13864         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
13865           .or. itype(i+3,1).eq.ntyp1 &
13866           .or. itype(i+4,1).eq.ntyp1) cycle
13867         dxi=dc(1,i)
13868         dyi=dc(2,i)
13869         dzi=dc(3,i)
13870         dx_normi=dc_norm(1,i)
13871         dy_normi=dc_norm(2,i)
13872         dz_normi=dc_norm(3,i)
13873         xmedi=c(1,i)+0.5d0*dxi
13874         ymedi=c(2,i)+0.5d0*dyi
13875         zmedi=c(3,i)+0.5d0*dzi
13876           xmedi=dmod(xmedi,boxxsize)
13877           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13878           ymedi=dmod(ymedi,boxysize)
13879           if (ymedi.lt.0) ymedi=ymedi+boxysize
13880           zmedi=dmod(zmedi,boxzsize)
13881           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13882         num_conti=num_cont_hb(i)
13883         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
13884         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
13885           call eturn4(i,eello_turn4)
13886         num_cont_hb(i)=num_conti
13887       enddo   ! i
13888 !
13889 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
13890 !
13891       do i=iatel_s,iatel_e
13892         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
13893         dxi=dc(1,i)
13894         dyi=dc(2,i)
13895         dzi=dc(3,i)
13896         dx_normi=dc_norm(1,i)
13897         dy_normi=dc_norm(2,i)
13898         dz_normi=dc_norm(3,i)
13899         xmedi=c(1,i)+0.5d0*dxi
13900         ymedi=c(2,i)+0.5d0*dyi
13901         zmedi=c(3,i)+0.5d0*dzi
13902           xmedi=dmod(xmedi,boxxsize)
13903           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13904           ymedi=dmod(ymedi,boxysize)
13905           if (ymedi.lt.0) ymedi=ymedi+boxysize
13906           zmedi=dmod(zmedi,boxzsize)
13907           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13908 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
13909         num_conti=num_cont_hb(i)
13910         do j=ielstart(i),ielend(i)
13911           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
13912           call eelecij_scale(i,j,ees,evdw1,eel_loc)
13913         enddo ! j
13914         num_cont_hb(i)=num_conti
13915       enddo   ! i
13916 !      write (iout,*) "Number of loop steps in EELEC:",ind
13917 !d      do i=1,nres
13918 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
13919 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
13920 !d      enddo
13921 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
13922 !cc      eel_loc=eel_loc+eello_turn3
13923 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
13924       return
13925       end subroutine eelec_scale
13926 !-----------------------------------------------------------------------------
13927       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
13928 !      implicit real*8 (a-h,o-z)
13929
13930       use comm_locel
13931 !      include 'DIMENSIONS'
13932 #ifdef MPI
13933       include "mpif.h"
13934 #endif
13935 !      include 'COMMON.CONTROL'
13936 !      include 'COMMON.IOUNITS'
13937 !      include 'COMMON.GEO'
13938 !      include 'COMMON.VAR'
13939 !      include 'COMMON.LOCAL'
13940 !      include 'COMMON.CHAIN'
13941 !      include 'COMMON.DERIV'
13942 !      include 'COMMON.INTERACT'
13943 !      include 'COMMON.CONTACTS'
13944 !      include 'COMMON.TORSION'
13945 !      include 'COMMON.VECTORS'
13946 !      include 'COMMON.FFIELD'
13947 !      include 'COMMON.TIME1'
13948       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
13949       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
13950       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13951 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13952       real(kind=8),dimension(4) :: muij
13953       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13954                     dist_temp, dist_init,sss_grad
13955       integer xshift,yshift,zshift
13956
13957 !el      integer :: num_conti,j1,j2
13958 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13959 !el                   dz_normi,xmedi,ymedi,zmedi
13960 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13961 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13962 !el          num_conti,j1,j2
13963 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13964 #ifdef MOMENT
13965       real(kind=8) :: scal_el=1.0d0
13966 #else
13967       real(kind=8) :: scal_el=0.5d0
13968 #endif
13969 ! 12/13/98
13970 ! 13-go grudnia roku pamietnego...
13971       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13972                                              0.0d0,1.0d0,0.0d0,&
13973                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13974 !el local variables
13975       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
13976       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
13977       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
13978       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
13979       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
13980       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
13981       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
13982                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
13983                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
13984                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
13985                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
13986                   ecosam,ecosbm,ecosgm,ghalf,time00
13987 !      integer :: maxconts
13988 !      maxconts = nres/4
13989 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13990 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13991 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13992 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13993 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13994 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13995 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13996 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13997 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
13998 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
13999 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14000 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14001 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14002
14003 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14004 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14005
14006 #ifdef MPI
14007           time00=MPI_Wtime()
14008 #endif
14009 !d      write (iout,*) "eelecij",i,j
14010 !el          ind=ind+1
14011           iteli=itel(i)
14012           itelj=itel(j)
14013           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14014           aaa=app(iteli,itelj)
14015           bbb=bpp(iteli,itelj)
14016           ael6i=ael6(iteli,itelj)
14017           ael3i=ael3(iteli,itelj)
14018           dxj=dc(1,j)
14019           dyj=dc(2,j)
14020           dzj=dc(3,j)
14021           dx_normj=dc_norm(1,j)
14022           dy_normj=dc_norm(2,j)
14023           dz_normj=dc_norm(3,j)
14024 !          xj=c(1,j)+0.5D0*dxj-xmedi
14025 !          yj=c(2,j)+0.5D0*dyj-ymedi
14026 !          zj=c(3,j)+0.5D0*dzj-zmedi
14027           xj=c(1,j)+0.5D0*dxj
14028           yj=c(2,j)+0.5D0*dyj
14029           zj=c(3,j)+0.5D0*dzj
14030           xj=mod(xj,boxxsize)
14031           if (xj.lt.0) xj=xj+boxxsize
14032           yj=mod(yj,boxysize)
14033           if (yj.lt.0) yj=yj+boxysize
14034           zj=mod(zj,boxzsize)
14035           if (zj.lt.0) zj=zj+boxzsize
14036       isubchap=0
14037       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14038       xj_safe=xj
14039       yj_safe=yj
14040       zj_safe=zj
14041       do xshift=-1,1
14042       do yshift=-1,1
14043       do zshift=-1,1
14044           xj=xj_safe+xshift*boxxsize
14045           yj=yj_safe+yshift*boxysize
14046           zj=zj_safe+zshift*boxzsize
14047           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14048           if(dist_temp.lt.dist_init) then
14049             dist_init=dist_temp
14050             xj_temp=xj
14051             yj_temp=yj
14052             zj_temp=zj
14053             isubchap=1
14054           endif
14055        enddo
14056        enddo
14057        enddo
14058        if (isubchap.eq.1) then
14059 !C          print *,i,j
14060           xj=xj_temp-xmedi
14061           yj=yj_temp-ymedi
14062           zj=zj_temp-zmedi
14063        else
14064           xj=xj_safe-xmedi
14065           yj=yj_safe-ymedi
14066           zj=zj_safe-zmedi
14067        endif
14068
14069           rij=xj*xj+yj*yj+zj*zj
14070           rrmij=1.0D0/rij
14071           rij=dsqrt(rij)
14072           rmij=1.0D0/rij
14073 ! For extracting the short-range part of Evdwpp
14074           sss=sscale(rij/rpp(iteli,itelj))
14075             sss_ele_cut=sscale_ele(rij)
14076             sss_ele_grad=sscagrad_ele(rij)
14077             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14078 !             sss_ele_cut=1.0d0
14079 !             sss_ele_grad=0.0d0
14080             if (sss_ele_cut.le.0.0) go to 128
14081
14082           r3ij=rrmij*rmij
14083           r6ij=r3ij*r3ij
14084           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14085           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14086           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14087           fac=cosa-3.0D0*cosb*cosg
14088           ev1=aaa*r6ij*r6ij
14089 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14090           if (j.eq.i+2) ev1=scal_el*ev1
14091           ev2=bbb*r6ij
14092           fac3=ael6i*r6ij
14093           fac4=ael3i*r3ij
14094           evdwij=ev1+ev2
14095           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14096           el2=fac4*fac
14097           eesij=el1+el2
14098 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14099           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14100           ees=ees+eesij*sss_ele_cut
14101           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14102 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14103 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14104 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14105 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14106
14107           if (energy_dec) then
14108               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14109               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14110           endif
14111
14112 !
14113 ! Calculate contributions to the Cartesian gradient.
14114 !
14115 #ifdef SPLITELE
14116           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14117           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14118           fac1=fac
14119           erij(1)=xj*rmij
14120           erij(2)=yj*rmij
14121           erij(3)=zj*rmij
14122 !
14123 ! Radial derivatives. First process both termini of the fragment (i,j)
14124 !
14125           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14126           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14127           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14128 !          do k=1,3
14129 !            ghalf=0.5D0*ggg(k)
14130 !            gelc(k,i)=gelc(k,i)+ghalf
14131 !            gelc(k,j)=gelc(k,j)+ghalf
14132 !          enddo
14133 ! 9/28/08 AL Gradient compotents will be summed only at the end
14134           do k=1,3
14135             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14136             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14137           enddo
14138 !
14139 ! Loop over residues i+1 thru j-1.
14140 !
14141 !grad          do k=i+1,j-1
14142 !grad            do l=1,3
14143 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14144 !grad            enddo
14145 !grad          enddo
14146           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14147           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14148           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14149           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14150           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14151           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14152 !          do k=1,3
14153 !            ghalf=0.5D0*ggg(k)
14154 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14155 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14156 !          enddo
14157 ! 9/28/08 AL Gradient compotents will be summed only at the end
14158           do k=1,3
14159             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14160             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14161           enddo
14162 !
14163 ! Loop over residues i+1 thru j-1.
14164 !
14165 !grad          do k=i+1,j-1
14166 !grad            do l=1,3
14167 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14168 !grad            enddo
14169 !grad          enddo
14170 #else
14171           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14172           facel=(el1+eesij)*sss_ele_cut
14173           fac1=fac
14174           fac=-3*rrmij*(facvdw+facvdw+facel)
14175           erij(1)=xj*rmij
14176           erij(2)=yj*rmij
14177           erij(3)=zj*rmij
14178 !
14179 ! Radial derivatives. First process both termini of the fragment (i,j)
14180 !
14181           ggg(1)=fac*xj
14182           ggg(2)=fac*yj
14183           ggg(3)=fac*zj
14184 !          do k=1,3
14185 !            ghalf=0.5D0*ggg(k)
14186 !            gelc(k,i)=gelc(k,i)+ghalf
14187 !            gelc(k,j)=gelc(k,j)+ghalf
14188 !          enddo
14189 ! 9/28/08 AL Gradient compotents will be summed only at the end
14190           do k=1,3
14191             gelc_long(k,j)=gelc(k,j)+ggg(k)
14192             gelc_long(k,i)=gelc(k,i)-ggg(k)
14193           enddo
14194 !
14195 ! Loop over residues i+1 thru j-1.
14196 !
14197 !grad          do k=i+1,j-1
14198 !grad            do l=1,3
14199 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14200 !grad            enddo
14201 !grad          enddo
14202 ! 9/28/08 AL Gradient compotents will be summed only at the end
14203           ggg(1)=facvdw*xj
14204           ggg(2)=facvdw*yj
14205           ggg(3)=facvdw*zj
14206           do k=1,3
14207             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14208             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14209           enddo
14210 #endif
14211 !
14212 ! Angular part
14213 !
14214           ecosa=2.0D0*fac3*fac1+fac4
14215           fac4=-3.0D0*fac4
14216           fac3=-6.0D0*fac3
14217           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14218           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14219           do k=1,3
14220             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14221             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14222           enddo
14223 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14224 !d   &          (dcosg(k),k=1,3)
14225           do k=1,3
14226             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14227           enddo
14228 !          do k=1,3
14229 !            ghalf=0.5D0*ggg(k)
14230 !            gelc(k,i)=gelc(k,i)+ghalf
14231 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14232 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14233 !            gelc(k,j)=gelc(k,j)+ghalf
14234 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14235 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14236 !          enddo
14237 !grad          do k=i+1,j-1
14238 !grad            do l=1,3
14239 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14240 !grad            enddo
14241 !grad          enddo
14242           do k=1,3
14243             gelc(k,i)=gelc(k,i) &
14244                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14245                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14246                      *sss_ele_cut
14247             gelc(k,j)=gelc(k,j) &
14248                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14249                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14250                      *sss_ele_cut
14251             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14252             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14253           enddo
14254           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14255               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14256               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14257 !
14258 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14259 !   energy of a peptide unit is assumed in the form of a second-order
14260 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14261 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14262 !   are computed for EVERY pair of non-contiguous peptide groups.
14263 !
14264           if (j.lt.nres-1) then
14265             j1=j+1
14266             j2=j-1
14267           else
14268             j1=j-1
14269             j2=j-2
14270           endif
14271           kkk=0
14272           do k=1,2
14273             do l=1,2
14274               kkk=kkk+1
14275               muij(kkk)=mu(k,i)*mu(l,j)
14276             enddo
14277           enddo
14278 !d         write (iout,*) 'EELEC: i',i,' j',j
14279 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14280 !d          write(iout,*) 'muij',muij
14281           ury=scalar(uy(1,i),erij)
14282           urz=scalar(uz(1,i),erij)
14283           vry=scalar(uy(1,j),erij)
14284           vrz=scalar(uz(1,j),erij)
14285           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14286           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14287           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14288           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14289           fac=dsqrt(-ael6i)*r3ij
14290           a22=a22*fac
14291           a23=a23*fac
14292           a32=a32*fac
14293           a33=a33*fac
14294 !d          write (iout,'(4i5,4f10.5)')
14295 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14296 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14297 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14298 !d     &      uy(:,j),uz(:,j)
14299 !d          write (iout,'(4f10.5)')
14300 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14301 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14302 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14303 !d           write (iout,'(9f10.5/)')
14304 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14305 ! Derivatives of the elements of A in virtual-bond vectors
14306           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14307           do k=1,3
14308             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14309             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14310             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14311             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14312             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14313             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14314             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14315             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14316             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14317             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14318             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14319             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14320           enddo
14321 ! Compute radial contributions to the gradient
14322           facr=-3.0d0*rrmij
14323           a22der=a22*facr
14324           a23der=a23*facr
14325           a32der=a32*facr
14326           a33der=a33*facr
14327           agg(1,1)=a22der*xj
14328           agg(2,1)=a22der*yj
14329           agg(3,1)=a22der*zj
14330           agg(1,2)=a23der*xj
14331           agg(2,2)=a23der*yj
14332           agg(3,2)=a23der*zj
14333           agg(1,3)=a32der*xj
14334           agg(2,3)=a32der*yj
14335           agg(3,3)=a32der*zj
14336           agg(1,4)=a33der*xj
14337           agg(2,4)=a33der*yj
14338           agg(3,4)=a33der*zj
14339 ! Add the contributions coming from er
14340           fac3=-3.0d0*fac
14341           do k=1,3
14342             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14343             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14344             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14345             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14346           enddo
14347           do k=1,3
14348 ! Derivatives in DC(i)
14349 !grad            ghalf1=0.5d0*agg(k,1)
14350 !grad            ghalf2=0.5d0*agg(k,2)
14351 !grad            ghalf3=0.5d0*agg(k,3)
14352 !grad            ghalf4=0.5d0*agg(k,4)
14353             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14354             -3.0d0*uryg(k,2)*vry)!+ghalf1
14355             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14356             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14357             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14358             -3.0d0*urzg(k,2)*vry)!+ghalf3
14359             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14360             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14361 ! Derivatives in DC(i+1)
14362             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14363             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14364             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14365             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14366             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14367             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14368             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14369             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14370 ! Derivatives in DC(j)
14371             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14372             -3.0d0*vryg(k,2)*ury)!+ghalf1
14373             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14374             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14375             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14376             -3.0d0*vryg(k,2)*urz)!+ghalf3
14377             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14378             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14379 ! Derivatives in DC(j+1) or DC(nres-1)
14380             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14381             -3.0d0*vryg(k,3)*ury)
14382             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14383             -3.0d0*vrzg(k,3)*ury)
14384             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14385             -3.0d0*vryg(k,3)*urz)
14386             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14387             -3.0d0*vrzg(k,3)*urz)
14388 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14389 !grad              do l=1,4
14390 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14391 !grad              enddo
14392 !grad            endif
14393           enddo
14394           acipa(1,1)=a22
14395           acipa(1,2)=a23
14396           acipa(2,1)=a32
14397           acipa(2,2)=a33
14398           a22=-a22
14399           a23=-a23
14400           do l=1,2
14401             do k=1,3
14402               agg(k,l)=-agg(k,l)
14403               aggi(k,l)=-aggi(k,l)
14404               aggi1(k,l)=-aggi1(k,l)
14405               aggj(k,l)=-aggj(k,l)
14406               aggj1(k,l)=-aggj1(k,l)
14407             enddo
14408           enddo
14409           if (j.lt.nres-1) then
14410             a22=-a22
14411             a32=-a32
14412             do l=1,3,2
14413               do k=1,3
14414                 agg(k,l)=-agg(k,l)
14415                 aggi(k,l)=-aggi(k,l)
14416                 aggi1(k,l)=-aggi1(k,l)
14417                 aggj(k,l)=-aggj(k,l)
14418                 aggj1(k,l)=-aggj1(k,l)
14419               enddo
14420             enddo
14421           else
14422             a22=-a22
14423             a23=-a23
14424             a32=-a32
14425             a33=-a33
14426             do l=1,4
14427               do k=1,3
14428                 agg(k,l)=-agg(k,l)
14429                 aggi(k,l)=-aggi(k,l)
14430                 aggi1(k,l)=-aggi1(k,l)
14431                 aggj(k,l)=-aggj(k,l)
14432                 aggj1(k,l)=-aggj1(k,l)
14433               enddo
14434             enddo
14435           endif
14436           ENDIF ! WCORR
14437           IF (wel_loc.gt.0.0d0) THEN
14438 ! Contribution to the local-electrostatic energy coming from the i-j pair
14439           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14440            +a33*muij(4)
14441 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14442
14443           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14444                   'eelloc',i,j,eel_loc_ij
14445 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14446
14447           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14448 ! Partial derivatives in virtual-bond dihedral angles gamma
14449           if (i.gt.1) &
14450           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14451                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14452                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14453                  *sss_ele_cut
14454           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14455                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14456                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14457                  *sss_ele_cut
14458            xtemp(1)=xj
14459            xtemp(2)=yj
14460            xtemp(3)=zj
14461
14462 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14463           do l=1,3
14464             ggg(l)=(agg(l,1)*muij(1)+ &
14465                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14466             *sss_ele_cut &
14467              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14468
14469             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14470             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14471 !grad            ghalf=0.5d0*ggg(l)
14472 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14473 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14474           enddo
14475 !grad          do k=i+1,j2
14476 !grad            do l=1,3
14477 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14478 !grad            enddo
14479 !grad          enddo
14480 ! Remaining derivatives of eello
14481           do l=1,3
14482             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14483                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14484             *sss_ele_cut
14485
14486             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14487                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14488             *sss_ele_cut
14489
14490             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14491                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14492             *sss_ele_cut
14493
14494             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14495                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14496             *sss_ele_cut
14497
14498           enddo
14499           ENDIF
14500 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14501 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14502           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14503              .and. num_conti.le.maxconts) then
14504 !            write (iout,*) i,j," entered corr"
14505 !
14506 ! Calculate the contact function. The ith column of the array JCONT will
14507 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14508 ! greater than I). The arrays FACONT and GACONT will contain the values of
14509 ! the contact function and its derivative.
14510 !           r0ij=1.02D0*rpp(iteli,itelj)
14511 !           r0ij=1.11D0*rpp(iteli,itelj)
14512             r0ij=2.20D0*rpp(iteli,itelj)
14513 !           r0ij=1.55D0*rpp(iteli,itelj)
14514             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14515 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14516             if (fcont.gt.0.0D0) then
14517               num_conti=num_conti+1
14518               if (num_conti.gt.maxconts) then
14519 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14520                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14521                                ' will skip next contacts for this conf.',num_conti
14522               else
14523                 jcont_hb(num_conti,i)=j
14524 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14525 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14526                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14527                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14528 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14529 !  terms.
14530                 d_cont(num_conti,i)=rij
14531 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14532 !     --- Electrostatic-interaction matrix ---
14533                 a_chuj(1,1,num_conti,i)=a22
14534                 a_chuj(1,2,num_conti,i)=a23
14535                 a_chuj(2,1,num_conti,i)=a32
14536                 a_chuj(2,2,num_conti,i)=a33
14537 !     --- Gradient of rij
14538                 do kkk=1,3
14539                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14540                 enddo
14541                 kkll=0
14542                 do k=1,2
14543                   do l=1,2
14544                     kkll=kkll+1
14545                     do m=1,3
14546                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14547                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14548                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14549                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14550                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14551                     enddo
14552                   enddo
14553                 enddo
14554                 ENDIF
14555                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14556 ! Calculate contact energies
14557                 cosa4=4.0D0*cosa
14558                 wij=cosa-3.0D0*cosb*cosg
14559                 cosbg1=cosb+cosg
14560                 cosbg2=cosb-cosg
14561 !               fac3=dsqrt(-ael6i)/r0ij**3
14562                 fac3=dsqrt(-ael6i)*r3ij
14563 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14564                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14565                 if (ees0tmp.gt.0) then
14566                   ees0pij=dsqrt(ees0tmp)
14567                 else
14568                   ees0pij=0
14569                 endif
14570 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14571                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14572                 if (ees0tmp.gt.0) then
14573                   ees0mij=dsqrt(ees0tmp)
14574                 else
14575                   ees0mij=0
14576                 endif
14577 !               ees0mij=0.0D0
14578                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14579                      *sss_ele_cut
14580
14581                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14582                      *sss_ele_cut
14583
14584 ! Diagnostics. Comment out or remove after debugging!
14585 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14586 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14587 !               ees0m(num_conti,i)=0.0D0
14588 ! End diagnostics.
14589 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14590 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14591 ! Angular derivatives of the contact function
14592                 ees0pij1=fac3/ees0pij
14593                 ees0mij1=fac3/ees0mij
14594                 fac3p=-3.0D0*fac3*rrmij
14595                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14596                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14597 !               ees0mij1=0.0D0
14598                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14599                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14600                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14601                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14602                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14603                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14604                 ecosap=ecosa1+ecosa2
14605                 ecosbp=ecosb1+ecosb2
14606                 ecosgp=ecosg1+ecosg2
14607                 ecosam=ecosa1-ecosa2
14608                 ecosbm=ecosb1-ecosb2
14609                 ecosgm=ecosg1-ecosg2
14610 ! Diagnostics
14611 !               ecosap=ecosa1
14612 !               ecosbp=ecosb1
14613 !               ecosgp=ecosg1
14614 !               ecosam=0.0D0
14615 !               ecosbm=0.0D0
14616 !               ecosgm=0.0D0
14617 ! End diagnostics
14618                 facont_hb(num_conti,i)=fcont
14619                 fprimcont=fprimcont/rij
14620 !d              facont_hb(num_conti,i)=1.0D0
14621 ! Following line is for diagnostics.
14622 !d              fprimcont=0.0D0
14623                 do k=1,3
14624                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14625                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14626                 enddo
14627                 do k=1,3
14628                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14629                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14630                 enddo
14631 !                gggp(1)=gggp(1)+ees0pijp*xj
14632 !                gggp(2)=gggp(2)+ees0pijp*yj
14633 !                gggp(3)=gggp(3)+ees0pijp*zj
14634 !                gggm(1)=gggm(1)+ees0mijp*xj
14635 !                gggm(2)=gggm(2)+ees0mijp*yj
14636 !                gggm(3)=gggm(3)+ees0mijp*zj
14637                 gggp(1)=gggp(1)+ees0pijp*xj &
14638                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14639                 gggp(2)=gggp(2)+ees0pijp*yj &
14640                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14641                 gggp(3)=gggp(3)+ees0pijp*zj &
14642                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14643
14644                 gggm(1)=gggm(1)+ees0mijp*xj &
14645                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14646
14647                 gggm(2)=gggm(2)+ees0mijp*yj &
14648                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14649
14650                 gggm(3)=gggm(3)+ees0mijp*zj &
14651                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14652
14653 ! Derivatives due to the contact function
14654                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14655                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14656                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14657                 do k=1,3
14658 !
14659 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14660 !          following the change of gradient-summation algorithm.
14661 !
14662 !grad                  ghalfp=0.5D0*gggp(k)
14663 !grad                  ghalfm=0.5D0*gggm(k)
14664 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14665 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14666 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14667 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14668 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14669 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14670 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14671 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14672 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14673 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14674 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14675 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14676 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14677 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14678                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14679                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14680                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14681                      *sss_ele_cut
14682
14683                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14684                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14685                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14686                      *sss_ele_cut
14687
14688                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14689                      *sss_ele_cut
14690
14691                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14692                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14693                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14694                      *sss_ele_cut
14695
14696                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14697                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14698                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14699                      *sss_ele_cut
14700
14701                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14702                      *sss_ele_cut
14703
14704                 enddo
14705               ENDIF ! wcorr
14706               endif  ! num_conti.le.maxconts
14707             endif  ! fcont.gt.0
14708           endif    ! j.gt.i+1
14709           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14710             do k=1,4
14711               do l=1,3
14712                 ghalf=0.5d0*agg(l,k)
14713                 aggi(l,k)=aggi(l,k)+ghalf
14714                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14715                 aggj(l,k)=aggj(l,k)+ghalf
14716               enddo
14717             enddo
14718             if (j.eq.nres-1 .and. i.lt.j-2) then
14719               do k=1,4
14720                 do l=1,3
14721                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14722                 enddo
14723               enddo
14724             endif
14725           endif
14726  128      continue
14727 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14728       return
14729       end subroutine eelecij_scale
14730 !-----------------------------------------------------------------------------
14731       subroutine evdwpp_short(evdw1)
14732 !
14733 ! Compute Evdwpp
14734 !
14735 !      implicit real*8 (a-h,o-z)
14736 !      include 'DIMENSIONS'
14737 !      include 'COMMON.CONTROL'
14738 !      include 'COMMON.IOUNITS'
14739 !      include 'COMMON.GEO'
14740 !      include 'COMMON.VAR'
14741 !      include 'COMMON.LOCAL'
14742 !      include 'COMMON.CHAIN'
14743 !      include 'COMMON.DERIV'
14744 !      include 'COMMON.INTERACT'
14745 !      include 'COMMON.CONTACTS'
14746 !      include 'COMMON.TORSION'
14747 !      include 'COMMON.VECTORS'
14748 !      include 'COMMON.FFIELD'
14749       real(kind=8),dimension(3) :: ggg
14750 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14751 #ifdef MOMENT
14752       real(kind=8) :: scal_el=1.0d0
14753 #else
14754       real(kind=8) :: scal_el=0.5d0
14755 #endif
14756 !el local variables
14757       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14758       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14759       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14760                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14761                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14762       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14763                     dist_temp, dist_init,sss_grad
14764       integer xshift,yshift,zshift
14765
14766
14767       evdw1=0.0D0
14768 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14769 !     & " iatel_e_vdw",iatel_e_vdw
14770       call flush(iout)
14771       do i=iatel_s_vdw,iatel_e_vdw
14772         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
14773         dxi=dc(1,i)
14774         dyi=dc(2,i)
14775         dzi=dc(3,i)
14776         dx_normi=dc_norm(1,i)
14777         dy_normi=dc_norm(2,i)
14778         dz_normi=dc_norm(3,i)
14779         xmedi=c(1,i)+0.5d0*dxi
14780         ymedi=c(2,i)+0.5d0*dyi
14781         zmedi=c(3,i)+0.5d0*dzi
14782           xmedi=dmod(xmedi,boxxsize)
14783           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14784           ymedi=dmod(ymedi,boxysize)
14785           if (ymedi.lt.0) ymedi=ymedi+boxysize
14786           zmedi=dmod(zmedi,boxzsize)
14787           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14788         num_conti=0
14789 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14790 !     &   ' ielend',ielend_vdw(i)
14791         call flush(iout)
14792         do j=ielstart_vdw(i),ielend_vdw(i)
14793           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14794 !el          ind=ind+1
14795           iteli=itel(i)
14796           itelj=itel(j)
14797           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14798           aaa=app(iteli,itelj)
14799           bbb=bpp(iteli,itelj)
14800           dxj=dc(1,j)
14801           dyj=dc(2,j)
14802           dzj=dc(3,j)
14803           dx_normj=dc_norm(1,j)
14804           dy_normj=dc_norm(2,j)
14805           dz_normj=dc_norm(3,j)
14806 !          xj=c(1,j)+0.5D0*dxj-xmedi
14807 !          yj=c(2,j)+0.5D0*dyj-ymedi
14808 !          zj=c(3,j)+0.5D0*dzj-zmedi
14809           xj=c(1,j)+0.5D0*dxj
14810           yj=c(2,j)+0.5D0*dyj
14811           zj=c(3,j)+0.5D0*dzj
14812           xj=mod(xj,boxxsize)
14813           if (xj.lt.0) xj=xj+boxxsize
14814           yj=mod(yj,boxysize)
14815           if (yj.lt.0) yj=yj+boxysize
14816           zj=mod(zj,boxzsize)
14817           if (zj.lt.0) zj=zj+boxzsize
14818       isubchap=0
14819       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14820       xj_safe=xj
14821       yj_safe=yj
14822       zj_safe=zj
14823       do xshift=-1,1
14824       do yshift=-1,1
14825       do zshift=-1,1
14826           xj=xj_safe+xshift*boxxsize
14827           yj=yj_safe+yshift*boxysize
14828           zj=zj_safe+zshift*boxzsize
14829           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14830           if(dist_temp.lt.dist_init) then
14831             dist_init=dist_temp
14832             xj_temp=xj
14833             yj_temp=yj
14834             zj_temp=zj
14835             isubchap=1
14836           endif
14837        enddo
14838        enddo
14839        enddo
14840        if (isubchap.eq.1) then
14841 !C          print *,i,j
14842           xj=xj_temp-xmedi
14843           yj=yj_temp-ymedi
14844           zj=zj_temp-zmedi
14845        else
14846           xj=xj_safe-xmedi
14847           yj=yj_safe-ymedi
14848           zj=zj_safe-zmedi
14849        endif
14850
14851           rij=xj*xj+yj*yj+zj*zj
14852           rrmij=1.0D0/rij
14853           rij=dsqrt(rij)
14854           sss=sscale(rij/rpp(iteli,itelj))
14855             sss_ele_cut=sscale_ele(rij)
14856             sss_ele_grad=sscagrad_ele(rij)
14857             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14858             if (sss_ele_cut.le.0.0) cycle
14859           if (sss.gt.0.0d0) then
14860             rmij=1.0D0/rij
14861             r3ij=rrmij*rmij
14862             r6ij=r3ij*r3ij
14863             ev1=aaa*r6ij*r6ij
14864 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14865             if (j.eq.i+2) ev1=scal_el*ev1
14866             ev2=bbb*r6ij
14867             evdwij=ev1+ev2
14868             if (energy_dec) then
14869               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14870             endif
14871             evdw1=evdw1+evdwij*sss*sss_ele_cut
14872 !
14873 ! Calculate contributions to the Cartesian gradient.
14874 !
14875             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
14876 !            ggg(1)=facvdw*xj
14877 !            ggg(2)=facvdw*yj
14878 !            ggg(3)=facvdw*zj
14879           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
14880           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14881           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
14882           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14883           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
14884           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14885
14886             do k=1,3
14887               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14888               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14889             enddo
14890           endif
14891         enddo ! j
14892       enddo   ! i
14893       return
14894       end subroutine evdwpp_short
14895 !-----------------------------------------------------------------------------
14896       subroutine escp_long(evdw2,evdw2_14)
14897 !
14898 ! This subroutine calculates the excluded-volume interaction energy between
14899 ! peptide-group centers and side chains and its gradient in virtual-bond and
14900 ! side-chain vectors.
14901 !
14902 !      implicit real*8 (a-h,o-z)
14903 !      include 'DIMENSIONS'
14904 !      include 'COMMON.GEO'
14905 !      include 'COMMON.VAR'
14906 !      include 'COMMON.LOCAL'
14907 !      include 'COMMON.CHAIN'
14908 !      include 'COMMON.DERIV'
14909 !      include 'COMMON.INTERACT'
14910 !      include 'COMMON.FFIELD'
14911 !      include 'COMMON.IOUNITS'
14912 !      include 'COMMON.CONTROL'
14913       real(kind=8),dimension(3) :: ggg
14914 !el local variables
14915       integer :: i,iint,j,k,iteli,itypj,subchap
14916       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
14917       real(kind=8) :: evdw2,evdw2_14,evdwij
14918       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14919                     dist_temp, dist_init
14920
14921       evdw2=0.0D0
14922       evdw2_14=0.0d0
14923 !d    print '(a)','Enter ESCP'
14924 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
14925       do i=iatscp_s,iatscp_e
14926         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14927         iteli=itel(i)
14928         xi=0.5D0*(c(1,i)+c(1,i+1))
14929         yi=0.5D0*(c(2,i)+c(2,i+1))
14930         zi=0.5D0*(c(3,i)+c(3,i+1))
14931           xi=mod(xi,boxxsize)
14932           if (xi.lt.0) xi=xi+boxxsize
14933           yi=mod(yi,boxysize)
14934           if (yi.lt.0) yi=yi+boxysize
14935           zi=mod(zi,boxzsize)
14936           if (zi.lt.0) zi=zi+boxzsize
14937
14938         do iint=1,nscp_gr(i)
14939
14940         do j=iscpstart(i,iint),iscpend(i,iint)
14941           itypj=itype(j,1)
14942           if (itypj.eq.ntyp1) cycle
14943 ! Uncomment following three lines for SC-p interactions
14944 !         xj=c(1,nres+j)-xi
14945 !         yj=c(2,nres+j)-yi
14946 !         zj=c(3,nres+j)-zi
14947 ! Uncomment following three lines for Ca-p interactions
14948           xj=c(1,j)
14949           yj=c(2,j)
14950           zj=c(3,j)
14951           xj=mod(xj,boxxsize)
14952           if (xj.lt.0) xj=xj+boxxsize
14953           yj=mod(yj,boxysize)
14954           if (yj.lt.0) yj=yj+boxysize
14955           zj=mod(zj,boxzsize)
14956           if (zj.lt.0) zj=zj+boxzsize
14957       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14958       xj_safe=xj
14959       yj_safe=yj
14960       zj_safe=zj
14961       subchap=0
14962       do xshift=-1,1
14963       do yshift=-1,1
14964       do zshift=-1,1
14965           xj=xj_safe+xshift*boxxsize
14966           yj=yj_safe+yshift*boxysize
14967           zj=zj_safe+zshift*boxzsize
14968           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14969           if(dist_temp.lt.dist_init) then
14970             dist_init=dist_temp
14971             xj_temp=xj
14972             yj_temp=yj
14973             zj_temp=zj
14974             subchap=1
14975           endif
14976        enddo
14977        enddo
14978        enddo
14979        if (subchap.eq.1) then
14980           xj=xj_temp-xi
14981           yj=yj_temp-yi
14982           zj=zj_temp-zi
14983        else
14984           xj=xj_safe-xi
14985           yj=yj_safe-yi
14986           zj=zj_safe-zi
14987        endif
14988           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14989
14990           rij=dsqrt(1.0d0/rrij)
14991             sss_ele_cut=sscale_ele(rij)
14992             sss_ele_grad=sscagrad_ele(rij)
14993 !            print *,sss_ele_cut,sss_ele_grad,&
14994 !            (rij),r_cut_ele,rlamb_ele
14995             if (sss_ele_cut.le.0.0) cycle
14996           sss=sscale((rij/rscp(itypj,iteli)))
14997           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
14998           if (sss.lt.1.0d0) then
14999
15000             fac=rrij**expon2
15001             e1=fac*fac*aad(itypj,iteli)
15002             e2=fac*bad(itypj,iteli)
15003             if (iabs(j-i) .le. 2) then
15004               e1=scal14*e1
15005               e2=scal14*e2
15006               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15007             endif
15008             evdwij=e1+e2
15009             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15010             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15011                 'evdw2',i,j,sss,evdwij
15012 !
15013 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15014 !
15015             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15016             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15017             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15018             ggg(1)=xj*fac
15019             ggg(2)=yj*fac
15020             ggg(3)=zj*fac
15021 ! Uncomment following three lines for SC-p interactions
15022 !           do k=1,3
15023 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15024 !           enddo
15025 ! Uncomment following line for SC-p interactions
15026 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15027             do k=1,3
15028               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15029               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15030             enddo
15031           endif
15032         enddo
15033
15034         enddo ! iint
15035       enddo ! i
15036       do i=1,nct
15037         do j=1,3
15038           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15039           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15040           gradx_scp(j,i)=expon*gradx_scp(j,i)
15041         enddo
15042       enddo
15043 !******************************************************************************
15044 !
15045 !                              N O T E !!!
15046 !
15047 ! To save time the factor EXPON has been extracted from ALL components
15048 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15049 ! use!
15050 !
15051 !******************************************************************************
15052       return
15053       end subroutine escp_long
15054 !-----------------------------------------------------------------------------
15055       subroutine escp_short(evdw2,evdw2_14)
15056 !
15057 ! This subroutine calculates the excluded-volume interaction energy between
15058 ! peptide-group centers and side chains and its gradient in virtual-bond and
15059 ! side-chain vectors.
15060 !
15061 !      implicit real*8 (a-h,o-z)
15062 !      include 'DIMENSIONS'
15063 !      include 'COMMON.GEO'
15064 !      include 'COMMON.VAR'
15065 !      include 'COMMON.LOCAL'
15066 !      include 'COMMON.CHAIN'
15067 !      include 'COMMON.DERIV'
15068 !      include 'COMMON.INTERACT'
15069 !      include 'COMMON.FFIELD'
15070 !      include 'COMMON.IOUNITS'
15071 !      include 'COMMON.CONTROL'
15072       real(kind=8),dimension(3) :: ggg
15073 !el local variables
15074       integer :: i,iint,j,k,iteli,itypj,subchap
15075       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15076       real(kind=8) :: evdw2,evdw2_14,evdwij
15077       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15078                     dist_temp, dist_init
15079
15080       evdw2=0.0D0
15081       evdw2_14=0.0d0
15082 !d    print '(a)','Enter ESCP'
15083 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15084       do i=iatscp_s,iatscp_e
15085         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15086         iteli=itel(i)
15087         xi=0.5D0*(c(1,i)+c(1,i+1))
15088         yi=0.5D0*(c(2,i)+c(2,i+1))
15089         zi=0.5D0*(c(3,i)+c(3,i+1))
15090           xi=mod(xi,boxxsize)
15091           if (xi.lt.0) xi=xi+boxxsize
15092           yi=mod(yi,boxysize)
15093           if (yi.lt.0) yi=yi+boxysize
15094           zi=mod(zi,boxzsize)
15095           if (zi.lt.0) zi=zi+boxzsize
15096
15097         do iint=1,nscp_gr(i)
15098
15099         do j=iscpstart(i,iint),iscpend(i,iint)
15100           itypj=itype(j,1)
15101           if (itypj.eq.ntyp1) cycle
15102 ! Uncomment following three lines for SC-p interactions
15103 !         xj=c(1,nres+j)-xi
15104 !         yj=c(2,nres+j)-yi
15105 !         zj=c(3,nres+j)-zi
15106 ! Uncomment following three lines for Ca-p interactions
15107 !          xj=c(1,j)-xi
15108 !          yj=c(2,j)-yi
15109 !          zj=c(3,j)-zi
15110           xj=c(1,j)
15111           yj=c(2,j)
15112           zj=c(3,j)
15113           xj=mod(xj,boxxsize)
15114           if (xj.lt.0) xj=xj+boxxsize
15115           yj=mod(yj,boxysize)
15116           if (yj.lt.0) yj=yj+boxysize
15117           zj=mod(zj,boxzsize)
15118           if (zj.lt.0) zj=zj+boxzsize
15119       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15120       xj_safe=xj
15121       yj_safe=yj
15122       zj_safe=zj
15123       subchap=0
15124       do xshift=-1,1
15125       do yshift=-1,1
15126       do zshift=-1,1
15127           xj=xj_safe+xshift*boxxsize
15128           yj=yj_safe+yshift*boxysize
15129           zj=zj_safe+zshift*boxzsize
15130           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15131           if(dist_temp.lt.dist_init) then
15132             dist_init=dist_temp
15133             xj_temp=xj
15134             yj_temp=yj
15135             zj_temp=zj
15136             subchap=1
15137           endif
15138        enddo
15139        enddo
15140        enddo
15141        if (subchap.eq.1) then
15142           xj=xj_temp-xi
15143           yj=yj_temp-yi
15144           zj=zj_temp-zi
15145        else
15146           xj=xj_safe-xi
15147           yj=yj_safe-yi
15148           zj=zj_safe-zi
15149        endif
15150
15151           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15152           rij=dsqrt(1.0d0/rrij)
15153             sss_ele_cut=sscale_ele(rij)
15154             sss_ele_grad=sscagrad_ele(rij)
15155 !            print *,sss_ele_cut,sss_ele_grad,&
15156 !            (rij),r_cut_ele,rlamb_ele
15157             if (sss_ele_cut.le.0.0) cycle
15158           sss=sscale(rij/rscp(itypj,iteli))
15159           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15160           if (sss.gt.0.0d0) then
15161
15162             fac=rrij**expon2
15163             e1=fac*fac*aad(itypj,iteli)
15164             e2=fac*bad(itypj,iteli)
15165             if (iabs(j-i) .le. 2) then
15166               e1=scal14*e1
15167               e2=scal14*e2
15168               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15169             endif
15170             evdwij=e1+e2
15171             evdw2=evdw2+evdwij*sss*sss_ele_cut
15172             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15173                 'evdw2',i,j,sss,evdwij
15174 !
15175 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15176 !
15177             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15178             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15179             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15180
15181             ggg(1)=xj*fac
15182             ggg(2)=yj*fac
15183             ggg(3)=zj*fac
15184 ! Uncomment following three lines for SC-p interactions
15185 !           do k=1,3
15186 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15187 !           enddo
15188 ! Uncomment following line for SC-p interactions
15189 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15190             do k=1,3
15191               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15192               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15193             enddo
15194           endif
15195         enddo
15196
15197         enddo ! iint
15198       enddo ! i
15199       do i=1,nct
15200         do j=1,3
15201           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15202           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15203           gradx_scp(j,i)=expon*gradx_scp(j,i)
15204         enddo
15205       enddo
15206 !******************************************************************************
15207 !
15208 !                              N O T E !!!
15209 !
15210 ! To save time the factor EXPON has been extracted from ALL components
15211 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15212 ! use!
15213 !
15214 !******************************************************************************
15215       return
15216       end subroutine escp_short
15217 !-----------------------------------------------------------------------------
15218 ! energy_p_new-sep_barrier.F
15219 !-----------------------------------------------------------------------------
15220       subroutine sc_grad_scale(scalfac)
15221 !      implicit real*8 (a-h,o-z)
15222       use calc_data
15223 !      include 'DIMENSIONS'
15224 !      include 'COMMON.CHAIN'
15225 !      include 'COMMON.DERIV'
15226 !      include 'COMMON.CALC'
15227 !      include 'COMMON.IOUNITS'
15228       real(kind=8),dimension(3) :: dcosom1,dcosom2
15229       real(kind=8) :: scalfac
15230 !el local variables
15231 !      integer :: i,j,k,l
15232
15233       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15234       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15235       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15236            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15237 ! diagnostics only
15238 !      eom1=0.0d0
15239 !      eom2=0.0d0
15240 !      eom12=evdwij*eps1_om12
15241 ! end diagnostics
15242 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15243 !     &  " sigder",sigder
15244 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15245 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15246       do k=1,3
15247         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15248         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15249       enddo
15250       do k=1,3
15251         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15252          *sss_ele_cut
15253       enddo
15254 !      write (iout,*) "gg",(gg(k),k=1,3)
15255       do k=1,3
15256         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15257                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15258                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15259                  *sss_ele_cut
15260         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15261                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15262                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15263          *sss_ele_cut
15264 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15265 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15266 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15267 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15268       enddo
15269 !
15270 ! Calculate the components of the gradient in DC and X
15271 !
15272       do l=1,3
15273         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15274         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15275       enddo
15276       return
15277       end subroutine sc_grad_scale
15278 !-----------------------------------------------------------------------------
15279 ! energy_split-sep.F
15280 !-----------------------------------------------------------------------------
15281       subroutine etotal_long(energia)
15282 !
15283 ! Compute the long-range slow-varying contributions to the energy
15284 !
15285 !      implicit real*8 (a-h,o-z)
15286 !      include 'DIMENSIONS'
15287       use MD_data, only: totT,usampl,eq_time
15288 #ifndef ISNAN
15289       external proc_proc
15290 #ifdef WINPGI
15291 !MS$ATTRIBUTES C ::  proc_proc
15292 #endif
15293 #endif
15294 #ifdef MPI
15295       include "mpif.h"
15296       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15297 #endif
15298 !      include 'COMMON.SETUP'
15299 !      include 'COMMON.IOUNITS'
15300 !      include 'COMMON.FFIELD'
15301 !      include 'COMMON.DERIV'
15302 !      include 'COMMON.INTERACT'
15303 !      include 'COMMON.SBRIDGE'
15304 !      include 'COMMON.CHAIN'
15305 !      include 'COMMON.VAR'
15306 !      include 'COMMON.LOCAL'
15307 !      include 'COMMON.MD'
15308       real(kind=8),dimension(0:n_ene) :: energia
15309 !el local variables
15310       integer :: i,n_corr,n_corr1,ierror,ierr
15311       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15312                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15313                   ecorr,ecorr5,ecorr6,eturn6,time00
15314 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15315 !elwrite(iout,*)"in etotal long"
15316
15317       if (modecalc.eq.12.or.modecalc.eq.14) then
15318 #ifdef MPI
15319 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15320 #else
15321         call int_from_cart1(.false.)
15322 #endif
15323       endif
15324 !elwrite(iout,*)"in etotal long"
15325
15326 #ifdef MPI
15327 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15328 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15329       call flush(iout)
15330       if (nfgtasks.gt.1) then
15331         time00=MPI_Wtime()
15332 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15333         if (fg_rank.eq.0) then
15334           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15335 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15336 !          call flush(iout)
15337 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15338 ! FG slaves as WEIGHTS array.
15339           weights_(1)=wsc
15340           weights_(2)=wscp
15341           weights_(3)=welec
15342           weights_(4)=wcorr
15343           weights_(5)=wcorr5
15344           weights_(6)=wcorr6
15345           weights_(7)=wel_loc
15346           weights_(8)=wturn3
15347           weights_(9)=wturn4
15348           weights_(10)=wturn6
15349           weights_(11)=wang
15350           weights_(12)=wscloc
15351           weights_(13)=wtor
15352           weights_(14)=wtor_d
15353           weights_(15)=wstrain
15354           weights_(16)=wvdwpp
15355           weights_(17)=wbond
15356           weights_(18)=scal14
15357           weights_(21)=wsccor
15358 ! FG Master broadcasts the WEIGHTS_ array
15359           call MPI_Bcast(weights_(1),n_ene,&
15360               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15361         else
15362 ! FG slaves receive the WEIGHTS array
15363           call MPI_Bcast(weights(1),n_ene,&
15364               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15365           wsc=weights(1)
15366           wscp=weights(2)
15367           welec=weights(3)
15368           wcorr=weights(4)
15369           wcorr5=weights(5)
15370           wcorr6=weights(6)
15371           wel_loc=weights(7)
15372           wturn3=weights(8)
15373           wturn4=weights(9)
15374           wturn6=weights(10)
15375           wang=weights(11)
15376           wscloc=weights(12)
15377           wtor=weights(13)
15378           wtor_d=weights(14)
15379           wstrain=weights(15)
15380           wvdwpp=weights(16)
15381           wbond=weights(17)
15382           scal14=weights(18)
15383           wsccor=weights(21)
15384         endif
15385         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15386           king,FG_COMM,IERR)
15387          time_Bcast=time_Bcast+MPI_Wtime()-time00
15388          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15389 !        call chainbuild_cart
15390 !        call int_from_cart1(.false.)
15391       endif
15392 !      write (iout,*) 'Processor',myrank,
15393 !     &  ' calling etotal_short ipot=',ipot
15394 !      call flush(iout)
15395 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15396 #endif
15397 !d    print *,'nnt=',nnt,' nct=',nct
15398 !
15399 !elwrite(iout,*)"in etotal long"
15400 ! Compute the side-chain and electrostatic interaction energy
15401 !
15402       goto (101,102,103,104,105,106) ipot
15403 ! Lennard-Jones potential.
15404   101 call elj_long(evdw)
15405 !d    print '(a)','Exit ELJ'
15406       goto 107
15407 ! Lennard-Jones-Kihara potential (shifted).
15408   102 call eljk_long(evdw)
15409       goto 107
15410 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15411   103 call ebp_long(evdw)
15412       goto 107
15413 ! Gay-Berne potential (shifted LJ, angular dependence).
15414   104 call egb_long(evdw)
15415       goto 107
15416 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15417   105 call egbv_long(evdw)
15418       goto 107
15419 ! Soft-sphere potential
15420   106 call e_softsphere(evdw)
15421 !
15422 ! Calculate electrostatic (H-bonding) energy of the main chain.
15423 !
15424   107 continue
15425       call vec_and_deriv
15426       if (ipot.lt.6) then
15427 #ifdef SPLITELE
15428          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15429              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15430              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15431              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15432 #else
15433          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15434              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15435              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15436              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15437 #endif
15438            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15439          else
15440             ees=0
15441             evdw1=0
15442             eel_loc=0
15443             eello_turn3=0
15444             eello_turn4=0
15445          endif
15446       else
15447 !        write (iout,*) "Soft-spheer ELEC potential"
15448         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15449          eello_turn4)
15450       endif
15451 !
15452 ! Calculate excluded-volume interaction energy between peptide groups
15453 ! and side chains.
15454 !
15455       if (ipot.lt.6) then
15456        if(wscp.gt.0d0) then
15457         call escp_long(evdw2,evdw2_14)
15458        else
15459         evdw2=0
15460         evdw2_14=0
15461        endif
15462       else
15463         call escp_soft_sphere(evdw2,evdw2_14)
15464       endif
15465 !
15466 ! 12/1/95 Multi-body terms
15467 !
15468       n_corr=0
15469       n_corr1=0
15470       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15471           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15472          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15473 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15474 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15475       else
15476          ecorr=0.0d0
15477          ecorr5=0.0d0
15478          ecorr6=0.0d0
15479          eturn6=0.0d0
15480       endif
15481       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15482          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15483       endif
15484 !
15485 ! If performing constraint dynamics, call the constraint energy
15486 !  after the equilibration time
15487       if(usampl.and.totT.gt.eq_time) then
15488          call EconstrQ
15489          call Econstr_back
15490       else
15491          Uconst=0.0d0
15492          Uconst_back=0.0d0
15493       endif
15494 !
15495 ! Sum the energies
15496 !
15497       do i=1,n_ene
15498         energia(i)=0.0d0
15499       enddo
15500       energia(1)=evdw
15501 #ifdef SCP14
15502       energia(2)=evdw2-evdw2_14
15503       energia(18)=evdw2_14
15504 #else
15505       energia(2)=evdw2
15506       energia(18)=0.0d0
15507 #endif
15508 #ifdef SPLITELE
15509       energia(3)=ees
15510       energia(16)=evdw1
15511 #else
15512       energia(3)=ees+evdw1
15513       energia(16)=0.0d0
15514 #endif
15515       energia(4)=ecorr
15516       energia(5)=ecorr5
15517       energia(6)=ecorr6
15518       energia(7)=eel_loc
15519       energia(8)=eello_turn3
15520       energia(9)=eello_turn4
15521       energia(10)=eturn6
15522       energia(20)=Uconst+Uconst_back
15523       call sum_energy(energia,.true.)
15524 !      write (iout,*) "Exit ETOTAL_LONG"
15525       call flush(iout)
15526       return
15527       end subroutine etotal_long
15528 !-----------------------------------------------------------------------------
15529       subroutine etotal_short(energia)
15530 !
15531 ! Compute the short-range fast-varying contributions to the energy
15532 !
15533 !      implicit real*8 (a-h,o-z)
15534 !      include 'DIMENSIONS'
15535 #ifndef ISNAN
15536       external proc_proc
15537 #ifdef WINPGI
15538 !MS$ATTRIBUTES C ::  proc_proc
15539 #endif
15540 #endif
15541 #ifdef MPI
15542       include "mpif.h"
15543       integer :: ierror,ierr
15544       real(kind=8),dimension(n_ene) :: weights_
15545       real(kind=8) :: time00
15546 #endif
15547 !      include 'COMMON.SETUP'
15548 !      include 'COMMON.IOUNITS'
15549 !      include 'COMMON.FFIELD'
15550 !      include 'COMMON.DERIV'
15551 !      include 'COMMON.INTERACT'
15552 !      include 'COMMON.SBRIDGE'
15553 !      include 'COMMON.CHAIN'
15554 !      include 'COMMON.VAR'
15555 !      include 'COMMON.LOCAL'
15556       real(kind=8),dimension(0:n_ene) :: energia
15557 !el local variables
15558       integer :: i,nres6
15559       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15560       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15561       nres6=6*nres
15562
15563 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15564 !      call flush(iout)
15565       if (modecalc.eq.12.or.modecalc.eq.14) then
15566 #ifdef MPI
15567         if (fg_rank.eq.0) call int_from_cart1(.false.)
15568 #else
15569         call int_from_cart1(.false.)
15570 #endif
15571       endif
15572 #ifdef MPI
15573 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15574 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15575 !      call flush(iout)
15576       if (nfgtasks.gt.1) then
15577         time00=MPI_Wtime()
15578 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15579         if (fg_rank.eq.0) then
15580           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15581 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15582 !          call flush(iout)
15583 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15584 ! FG slaves as WEIGHTS array.
15585           weights_(1)=wsc
15586           weights_(2)=wscp
15587           weights_(3)=welec
15588           weights_(4)=wcorr
15589           weights_(5)=wcorr5
15590           weights_(6)=wcorr6
15591           weights_(7)=wel_loc
15592           weights_(8)=wturn3
15593           weights_(9)=wturn4
15594           weights_(10)=wturn6
15595           weights_(11)=wang
15596           weights_(12)=wscloc
15597           weights_(13)=wtor
15598           weights_(14)=wtor_d
15599           weights_(15)=wstrain
15600           weights_(16)=wvdwpp
15601           weights_(17)=wbond
15602           weights_(18)=scal14
15603           weights_(21)=wsccor
15604 ! FG Master broadcasts the WEIGHTS_ array
15605           call MPI_Bcast(weights_(1),n_ene,&
15606               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15607         else
15608 ! FG slaves receive the WEIGHTS array
15609           call MPI_Bcast(weights(1),n_ene,&
15610               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15611           wsc=weights(1)
15612           wscp=weights(2)
15613           welec=weights(3)
15614           wcorr=weights(4)
15615           wcorr5=weights(5)
15616           wcorr6=weights(6)
15617           wel_loc=weights(7)
15618           wturn3=weights(8)
15619           wturn4=weights(9)
15620           wturn6=weights(10)
15621           wang=weights(11)
15622           wscloc=weights(12)
15623           wtor=weights(13)
15624           wtor_d=weights(14)
15625           wstrain=weights(15)
15626           wvdwpp=weights(16)
15627           wbond=weights(17)
15628           scal14=weights(18)
15629           wsccor=weights(21)
15630         endif
15631 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15632         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15633           king,FG_COMM,IERR)
15634 !        write (iout,*) "Processor",myrank," BROADCAST c"
15635         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15636           king,FG_COMM,IERR)
15637 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15638         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15639           king,FG_COMM,IERR)
15640 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15641         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15642           king,FG_COMM,IERR)
15643 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15644         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15645           king,FG_COMM,IERR)
15646 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15647         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15648           king,FG_COMM,IERR)
15649 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15650         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15651           king,FG_COMM,IERR)
15652 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15653         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15654           king,FG_COMM,IERR)
15655 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15656         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15657           king,FG_COMM,IERR)
15658          time_Bcast=time_Bcast+MPI_Wtime()-time00
15659 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15660       endif
15661 !      write (iout,*) 'Processor',myrank,
15662 !     &  ' calling etotal_short ipot=',ipot
15663 !      call flush(iout)
15664 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15665 #endif
15666 !      call int_from_cart1(.false.)
15667 !
15668 ! Compute the side-chain and electrostatic interaction energy
15669 !
15670       goto (101,102,103,104,105,106) ipot
15671 ! Lennard-Jones potential.
15672   101 call elj_short(evdw)
15673 !d    print '(a)','Exit ELJ'
15674       goto 107
15675 ! Lennard-Jones-Kihara potential (shifted).
15676   102 call eljk_short(evdw)
15677       goto 107
15678 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15679   103 call ebp_short(evdw)
15680       goto 107
15681 ! Gay-Berne potential (shifted LJ, angular dependence).
15682   104 call egb_short(evdw)
15683       goto 107
15684 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15685   105 call egbv_short(evdw)
15686       goto 107
15687 ! Soft-sphere potential - already dealt with in the long-range part
15688   106 evdw=0.0d0
15689 !  106 call e_softsphere_short(evdw)
15690 !
15691 ! Calculate electrostatic (H-bonding) energy of the main chain.
15692 !
15693   107 continue
15694 !
15695 ! Calculate the short-range part of Evdwpp
15696 !
15697       call evdwpp_short(evdw1)
15698 !
15699 ! Calculate the short-range part of ESCp
15700 !
15701       if (ipot.lt.6) then
15702         call escp_short(evdw2,evdw2_14)
15703       endif
15704 !
15705 ! Calculate the bond-stretching energy
15706 !
15707       call ebond(estr)
15708 !
15709 ! Calculate the disulfide-bridge and other energy and the contributions
15710 ! from other distance constraints.
15711       call edis(ehpb)
15712 !
15713 ! Calculate the virtual-bond-angle energy.
15714 !
15715       call ebend(ebe,ethetacnstr)
15716 !
15717 ! Calculate the SC local energy.
15718 !
15719       call vec_and_deriv
15720       call esc(escloc)
15721 !
15722 ! Calculate the virtual-bond torsional energy.
15723 !
15724       call etor(etors,edihcnstr)
15725 !
15726 ! 6/23/01 Calculate double-torsional energy
15727 !
15728       call etor_d(etors_d)
15729 !
15730 ! 21/5/07 Calculate local sicdechain correlation energy
15731 !
15732       if (wsccor.gt.0.0d0) then
15733         call eback_sc_corr(esccor)
15734       else
15735         esccor=0.0d0
15736       endif
15737 !
15738 ! Put energy components into an array
15739 !
15740       do i=1,n_ene
15741         energia(i)=0.0d0
15742       enddo
15743       energia(1)=evdw
15744 #ifdef SCP14
15745       energia(2)=evdw2-evdw2_14
15746       energia(18)=evdw2_14
15747 #else
15748       energia(2)=evdw2
15749       energia(18)=0.0d0
15750 #endif
15751 #ifdef SPLITELE
15752       energia(16)=evdw1
15753 #else
15754       energia(3)=evdw1
15755 #endif
15756       energia(11)=ebe
15757       energia(12)=escloc
15758       energia(13)=etors
15759       energia(14)=etors_d
15760       energia(15)=ehpb
15761       energia(17)=estr
15762       energia(19)=edihcnstr
15763       energia(21)=esccor
15764 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15765       call flush(iout)
15766       call sum_energy(energia,.true.)
15767 !      write (iout,*) "Exit ETOTAL_SHORT"
15768       call flush(iout)
15769       return
15770       end subroutine etotal_short
15771 !-----------------------------------------------------------------------------
15772 ! gnmr1.f
15773 !-----------------------------------------------------------------------------
15774       real(kind=8) function gnmr1(y,ymin,ymax)
15775 !      implicit none
15776       real(kind=8) :: y,ymin,ymax
15777       real(kind=8) :: wykl=4.0d0
15778       if (y.lt.ymin) then
15779         gnmr1=(ymin-y)**wykl/wykl
15780       else if (y.gt.ymax) then
15781         gnmr1=(y-ymax)**wykl/wykl
15782       else
15783         gnmr1=0.0d0
15784       endif
15785       return
15786       end function gnmr1
15787 !-----------------------------------------------------------------------------
15788       real(kind=8) function gnmr1prim(y,ymin,ymax)
15789 !      implicit none
15790       real(kind=8) :: y,ymin,ymax
15791       real(kind=8) :: wykl=4.0d0
15792       if (y.lt.ymin) then
15793         gnmr1prim=-(ymin-y)**(wykl-1)
15794       else if (y.gt.ymax) then
15795         gnmr1prim=(y-ymax)**(wykl-1)
15796       else
15797         gnmr1prim=0.0d0
15798       endif
15799       return
15800       end function gnmr1prim
15801 !----------------------------------------------------------------------------
15802       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
15803       real(kind=8) y,ymin,ymax,sigma
15804       real(kind=8) wykl /4.0d0/
15805       if (y.lt.ymin) then
15806         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
15807       else if (y.gt.ymax) then
15808         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
15809       else
15810         rlornmr1=0.0d0
15811       endif
15812       return
15813       end function rlornmr1
15814 !------------------------------------------------------------------------------
15815       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
15816       real(kind=8) y,ymin,ymax,sigma
15817       real(kind=8) wykl /4.0d0/
15818       if (y.lt.ymin) then
15819         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
15820         ((ymin-y)**wykl+sigma**wykl)**2
15821       else if (y.gt.ymax) then
15822         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
15823         ((y-ymax)**wykl+sigma**wykl)**2
15824       else
15825         rlornmr1prim=0.0d0
15826       endif
15827       return
15828       end function rlornmr1prim
15829
15830       real(kind=8) function harmonic(y,ymax)
15831 !      implicit none
15832       real(kind=8) :: y,ymax
15833       real(kind=8) :: wykl=2.0d0
15834       harmonic=(y-ymax)**wykl
15835       return
15836       end function harmonic
15837 !-----------------------------------------------------------------------------
15838       real(kind=8) function harmonicprim(y,ymax)
15839       real(kind=8) :: y,ymin,ymax
15840       real(kind=8) :: wykl=2.0d0
15841       harmonicprim=(y-ymax)*wykl
15842       return
15843       end function harmonicprim
15844 !-----------------------------------------------------------------------------
15845 ! gradient_p.F
15846 !-----------------------------------------------------------------------------
15847       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
15848
15849       use io_base, only:intout,briefout
15850 !      implicit real*8 (a-h,o-z)
15851 !      include 'DIMENSIONS'
15852 !      include 'COMMON.CHAIN'
15853 !      include 'COMMON.DERIV'
15854 !      include 'COMMON.VAR'
15855 !      include 'COMMON.INTERACT'
15856 !      include 'COMMON.FFIELD'
15857 !      include 'COMMON.MD'
15858 !      include 'COMMON.IOUNITS'
15859       real(kind=8),external :: ufparm
15860       integer :: uiparm(1)
15861       real(kind=8) :: urparm(1)
15862       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
15863       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
15864       integer :: n,nf,ind,ind1,i,k,j
15865 !
15866 ! This subroutine calculates total internal coordinate gradient.
15867 ! Depending on the number of function evaluations, either whole energy
15868 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
15869 ! internal coordinates are reevaluated or only the cartesian-in-internal
15870 ! coordinate derivatives are evaluated. The subroutine was designed to work
15871 ! with SUMSL.
15872 !
15873 !
15874       icg=mod(nf,2)+1
15875
15876 !d      print *,'grad',nf,icg
15877       if (nf-nfl+1) 20,30,40
15878    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
15879 !    write (iout,*) 'grad 20'
15880       if (nf.eq.0) return
15881       goto 40
15882    30 call var_to_geom(n,x)
15883       call chainbuild
15884 !    write (iout,*) 'grad 30'
15885 !
15886 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
15887 !
15888    40 call cartder
15889 !     write (iout,*) 'grad 40'
15890 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
15891 !
15892 ! Convert the Cartesian gradient into internal-coordinate gradient.
15893 !
15894       ind=0
15895       ind1=0
15896       do i=1,nres-2
15897         gthetai=0.0D0
15898         gphii=0.0D0
15899         do j=i+1,nres-1
15900           ind=ind+1
15901 !         ind=indmat(i,j)
15902 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
15903           do k=1,3
15904             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
15905           enddo
15906           do k=1,3
15907             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
15908           enddo
15909         enddo
15910         do j=i+1,nres-1
15911           ind1=ind1+1
15912 !         ind1=indmat(i,j)
15913 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
15914           do k=1,3
15915             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
15916             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
15917           enddo
15918         enddo
15919         if (i.gt.1) g(i-1)=gphii
15920         if (n.gt.nphi) g(nphi+i)=gthetai
15921       enddo
15922       if (n.le.nphi+ntheta) goto 10
15923       do i=2,nres-1
15924         if (itype(i,1).ne.10) then
15925           galphai=0.0D0
15926           gomegai=0.0D0
15927           do k=1,3
15928             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
15929           enddo
15930           do k=1,3
15931             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
15932           enddo
15933           g(ialph(i,1))=galphai
15934           g(ialph(i,1)+nside)=gomegai
15935         endif
15936       enddo
15937 !
15938 ! Add the components corresponding to local energy terms.
15939 !
15940    10 continue
15941       do i=1,nvar
15942 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
15943         g(i)=g(i)+gloc(i,icg)
15944       enddo
15945 ! Uncomment following three lines for diagnostics.
15946 !d    call intout
15947 !elwrite(iout,*) "in gradient after calling intout"
15948 !d    call briefout(0,0.0d0)
15949 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
15950       return
15951       end subroutine gradient
15952 !-----------------------------------------------------------------------------
15953       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
15954
15955       use comm_chu
15956 !      implicit real*8 (a-h,o-z)
15957 !      include 'DIMENSIONS'
15958 !      include 'COMMON.DERIV'
15959 !      include 'COMMON.IOUNITS'
15960 !      include 'COMMON.GEO'
15961       integer :: n,nf
15962 !el      integer :: jjj
15963 !el      common /chuju/ jjj
15964       real(kind=8) :: energia(0:n_ene)
15965       integer :: uiparm(1)
15966       real(kind=8) :: urparm(1)
15967       real(kind=8) :: f
15968       real(kind=8),external :: ufparm
15969       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
15970 !     if (jjj.gt.0) then
15971 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15972 !     endif
15973       nfl=nf
15974       icg=mod(nf,2)+1
15975 !d      print *,'func',nf,nfl,icg
15976       call var_to_geom(n,x)
15977       call zerograd
15978       call chainbuild
15979 !d    write (iout,*) 'ETOTAL called from FUNC'
15980       call etotal(energia)
15981       call sum_gradient
15982       f=energia(0)
15983 !     if (jjj.gt.0) then
15984 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15985 !       write (iout,*) 'f=',etot
15986 !       jjj=0
15987 !     endif
15988       return
15989       end subroutine func
15990 !-----------------------------------------------------------------------------
15991       subroutine cartgrad
15992 !      implicit real*8 (a-h,o-z)
15993 !      include 'DIMENSIONS'
15994       use energy_data
15995       use MD_data, only: totT,usampl,eq_time
15996 #ifdef MPI
15997       include 'mpif.h'
15998 #endif
15999 !      include 'COMMON.CHAIN'
16000 !      include 'COMMON.DERIV'
16001 !      include 'COMMON.VAR'
16002 !      include 'COMMON.INTERACT'
16003 !      include 'COMMON.FFIELD'
16004 !      include 'COMMON.MD'
16005 !      include 'COMMON.IOUNITS'
16006 !      include 'COMMON.TIME1'
16007 !
16008       integer :: i,j
16009
16010 ! This subrouting calculates total Cartesian coordinate gradient.
16011 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16012 !
16013 !el#define DEBUG
16014 #ifdef TIMING
16015       time00=MPI_Wtime()
16016 #endif
16017       icg=1
16018       call sum_gradient
16019 #ifdef TIMING
16020 #endif
16021 !el      write (iout,*) "After sum_gradient"
16022 #ifdef DEBUG
16023 !el      write (iout,*) "After sum_gradient"
16024       do i=1,nres-1
16025         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16026         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16027       enddo
16028 #endif
16029 ! If performing constraint dynamics, add the gradients of the constraint energy
16030       if(usampl.and.totT.gt.eq_time) then
16031          do i=1,nct
16032            do j=1,3
16033              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16034              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16035            enddo
16036          enddo
16037          do i=1,nres-3
16038            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16039          enddo
16040          do i=1,nres-2
16041            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16042          enddo
16043       endif
16044 !elwrite (iout,*) "After sum_gradient"
16045 #ifdef TIMING
16046       time01=MPI_Wtime()
16047 #endif
16048       call intcartderiv
16049 !elwrite (iout,*) "After sum_gradient"
16050 #ifdef TIMING
16051       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16052 #endif
16053 !     call checkintcartgrad
16054 !     write(iout,*) 'calling int_to_cart'
16055 #ifdef DEBUG
16056       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16057 #endif
16058       do i=0,nct
16059         do j=1,3
16060           gcart(j,i)=gradc(j,i,icg)
16061           gxcart(j,i)=gradx(j,i,icg)
16062         enddo
16063 #ifdef DEBUG
16064         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16065           (gxcart(j,i),j=1,3),gloc(i,icg)
16066 #endif
16067       enddo
16068 #ifdef TIMING
16069       time01=MPI_Wtime()
16070 #endif
16071       call int_to_cart
16072 #ifdef TIMING
16073       time_inttocart=time_inttocart+MPI_Wtime()-time01
16074 #endif
16075 #ifdef DEBUG
16076       write (iout,*) "gcart and gxcart after int_to_cart"
16077       do i=0,nres-1
16078         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16079             (gxcart(j,i),j=1,3)
16080       enddo
16081 #endif
16082 #ifdef CARGRAD
16083 #ifdef DEBUG
16084       write (iout,*) "CARGRAD"
16085 #endif
16086       do i=nres,0,-1
16087         do j=1,3
16088           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16089 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16090         enddo
16091 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16092 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16093       enddo
16094 ! Correction: dummy residues
16095         if (nnt.gt.1) then
16096           do j=1,3
16097 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16098             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16099           enddo
16100         endif
16101         if (nct.lt.nres) then
16102           do j=1,3
16103 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16104             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16105           enddo
16106         endif
16107 #endif
16108 #ifdef TIMING
16109       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16110 #endif
16111 !el#undef DEBUG
16112       return
16113       end subroutine cartgrad
16114 !-----------------------------------------------------------------------------
16115       subroutine zerograd
16116 !      implicit real*8 (a-h,o-z)
16117 !      include 'DIMENSIONS'
16118 !      include 'COMMON.DERIV'
16119 !      include 'COMMON.CHAIN'
16120 !      include 'COMMON.VAR'
16121 !      include 'COMMON.MD'
16122 !      include 'COMMON.SCCOR'
16123 !
16124 !el local variables
16125       integer :: i,j,intertyp,k
16126 ! Initialize Cartesian-coordinate gradient
16127 !
16128 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16129 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16130
16131 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16132 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16133 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16134 !      allocate(gradcorr_long(3,nres))
16135 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16136 !      allocate(gcorr6_turn_long(3,nres))
16137 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16138
16139 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16140
16141 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16142 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16143
16144 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16145 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16146
16147 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16148 !      allocate(gscloc(3,nres)) !(3,maxres)
16149 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16150
16151
16152
16153 !      common /deriv_scloc/
16154 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16155 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16156 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
16157 !      common /mpgrad/
16158 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16159
16160
16161
16162 !          gradc(j,i,icg)=0.0d0
16163 !          gradx(j,i,icg)=0.0d0
16164
16165 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16166 !elwrite(iout,*) "icg",icg
16167       do i=-1,nres
16168         do j=1,3
16169           gvdwx(j,i)=0.0D0
16170           gradx_scp(j,i)=0.0D0
16171           gvdwc(j,i)=0.0D0
16172           gvdwc_scp(j,i)=0.0D0
16173           gvdwc_scpp(j,i)=0.0d0
16174           gelc(j,i)=0.0D0
16175           gelc_long(j,i)=0.0D0
16176           gradb(j,i)=0.0d0
16177           gradbx(j,i)=0.0d0
16178           gvdwpp(j,i)=0.0d0
16179           gel_loc(j,i)=0.0d0
16180           gel_loc_long(j,i)=0.0d0
16181           ghpbc(j,i)=0.0D0
16182           ghpbx(j,i)=0.0D0
16183           gcorr3_turn(j,i)=0.0d0
16184           gcorr4_turn(j,i)=0.0d0
16185           gradcorr(j,i)=0.0d0
16186           gradcorr_long(j,i)=0.0d0
16187           gradcorr5_long(j,i)=0.0d0
16188           gradcorr6_long(j,i)=0.0d0
16189           gcorr6_turn_long(j,i)=0.0d0
16190           gradcorr5(j,i)=0.0d0
16191           gradcorr6(j,i)=0.0d0
16192           gcorr6_turn(j,i)=0.0d0
16193           gsccorc(j,i)=0.0d0
16194           gsccorx(j,i)=0.0d0
16195           gradc(j,i,icg)=0.0d0
16196           gradx(j,i,icg)=0.0d0
16197           gscloc(j,i)=0.0d0
16198           gsclocx(j,i)=0.0d0
16199           gliptran(j,i)=0.0d0
16200           gliptranx(j,i)=0.0d0
16201           gliptranc(j,i)=0.0d0
16202           gshieldx(j,i)=0.0d0
16203           gshieldc(j,i)=0.0d0
16204           gshieldc_loc(j,i)=0.0d0
16205           gshieldx_ec(j,i)=0.0d0
16206           gshieldc_ec(j,i)=0.0d0
16207           gshieldc_loc_ec(j,i)=0.0d0
16208           gshieldx_t3(j,i)=0.0d0
16209           gshieldc_t3(j,i)=0.0d0
16210           gshieldc_loc_t3(j,i)=0.0d0
16211           gshieldx_t4(j,i)=0.0d0
16212           gshieldc_t4(j,i)=0.0d0
16213           gshieldc_loc_t4(j,i)=0.0d0
16214           gshieldx_ll(j,i)=0.0d0
16215           gshieldc_ll(j,i)=0.0d0
16216           gshieldc_loc_ll(j,i)=0.0d0
16217           gg_tube(j,i)=0.0d0
16218           gg_tube_sc(j,i)=0.0d0
16219           gradafm(j,i)=0.0d0
16220           gradb_nucl(j,i)=0.0d0
16221           gradbx_nucl(j,i)=0.0d0
16222           do intertyp=1,3
16223            gloc_sc(intertyp,i,icg)=0.0d0
16224           enddo
16225         enddo
16226       enddo
16227       do i=1,nres
16228        do j=1,maxcontsshi
16229        shield_list(j,i)=0
16230         do k=1,3
16231 !C           print *,i,j,k
16232            grad_shield_side(k,j,i)=0.0d0
16233            grad_shield_loc(k,j,i)=0.0d0
16234          enddo
16235        enddo
16236        ishield_list(i)=0
16237       enddo
16238
16239 !
16240 ! Initialize the gradient of local energy terms.
16241 !
16242 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
16243 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16244 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16245 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
16246 !      allocate(gel_loc_turn3(nres))
16247 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16248 !      allocate(gsccor_loc(nres))       !(maxres)
16249
16250       do i=1,4*nres
16251         gloc(i,icg)=0.0D0
16252       enddo
16253       do i=1,nres
16254         gel_loc_loc(i)=0.0d0
16255         gcorr_loc(i)=0.0d0
16256         g_corr5_loc(i)=0.0d0
16257         g_corr6_loc(i)=0.0d0
16258         gel_loc_turn3(i)=0.0d0
16259         gel_loc_turn4(i)=0.0d0
16260         gel_loc_turn6(i)=0.0d0
16261         gsccor_loc(i)=0.0d0
16262       enddo
16263 ! initialize gcart and gxcart
16264 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16265       do i=0,nres
16266         do j=1,3
16267           gcart(j,i)=0.0d0
16268           gxcart(j,i)=0.0d0
16269         enddo
16270       enddo
16271       return
16272       end subroutine zerograd
16273 !-----------------------------------------------------------------------------
16274       real(kind=8) function fdum()
16275       fdum=0.0D0
16276       return
16277       end function fdum
16278 !-----------------------------------------------------------------------------
16279 ! intcartderiv.F
16280 !-----------------------------------------------------------------------------
16281       subroutine intcartderiv
16282 !      implicit real*8 (a-h,o-z)
16283 !      include 'DIMENSIONS'
16284 #ifdef MPI
16285       include 'mpif.h'
16286 #endif
16287 !      include 'COMMON.SETUP'
16288 !      include 'COMMON.CHAIN'
16289 !      include 'COMMON.VAR'
16290 !      include 'COMMON.GEO'
16291 !      include 'COMMON.INTERACT'
16292 !      include 'COMMON.DERIV'
16293 !      include 'COMMON.IOUNITS'
16294 !      include 'COMMON.LOCAL'
16295 !      include 'COMMON.SCCOR'
16296       real(kind=8) :: pi4,pi34
16297       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16298       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16299                     dcosomega,dsinomega !(3,3,maxres)
16300       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16301
16302       integer :: i,j,k
16303       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16304                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16305                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16306                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16307       integer :: nres2
16308       nres2=2*nres
16309
16310 !el from module energy-------------
16311 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16312 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16313 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16314
16315 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16316 !el      allocate(dsintau(3,3,3,0:nres2))
16317 !el      allocate(dtauangle(3,3,3,0:nres2))
16318 !el      allocate(domicron(3,2,2,0:nres2))
16319 !el      allocate(dcosomicron(3,2,2,0:nres2))
16320
16321
16322
16323 #if defined(MPI) && defined(PARINTDER)
16324       if (nfgtasks.gt.1 .and. me.eq.king) &
16325         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16326 #endif
16327       pi4 = 0.5d0*pipol
16328       pi34 = 3*pi4
16329
16330 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
16331 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16332
16333 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16334       do i=1,nres
16335         do j=1,3
16336           dtheta(j,1,i)=0.0d0
16337           dtheta(j,2,i)=0.0d0
16338           dphi(j,1,i)=0.0d0
16339           dphi(j,2,i)=0.0d0
16340           dphi(j,3,i)=0.0d0
16341         enddo
16342       enddo
16343 ! Derivatives of theta's
16344 #if defined(MPI) && defined(PARINTDER)
16345 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16346       do i=max0(ithet_start-1,3),ithet_end
16347 #else
16348       do i=3,nres
16349 #endif
16350         cost=dcos(theta(i))
16351         sint=sqrt(1-cost*cost)
16352         do j=1,3
16353           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16354           vbld(i-1)
16355           if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16356           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16357           vbld(i)
16358           if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16359         enddo
16360       enddo
16361 #if defined(MPI) && defined(PARINTDER)
16362 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16363       do i=max0(ithet_start-1,3),ithet_end
16364 #else
16365       do i=3,nres
16366 #endif
16367       if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16368         cost1=dcos(omicron(1,i))
16369         sint1=sqrt(1-cost1*cost1)
16370         cost2=dcos(omicron(2,i))
16371         sint2=sqrt(1-cost2*cost2)
16372        do j=1,3
16373 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16374           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16375           cost1*dc_norm(j,i-2))/ &
16376           vbld(i-1)
16377           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16378           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16379           +cost1*(dc_norm(j,i-1+nres)))/ &
16380           vbld(i-1+nres)
16381           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16382 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16383 !C Looks messy but better than if in loop
16384           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16385           +cost2*dc_norm(j,i-1))/ &
16386           vbld(i)
16387           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16388           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16389            +cost2*(-dc_norm(j,i-1+nres)))/ &
16390           vbld(i-1+nres)
16391 !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16392           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16393         enddo
16394        endif
16395       enddo
16396 !elwrite(iout,*) "after vbld write"
16397 ! Derivatives of phi:
16398 ! If phi is 0 or 180 degrees, then the formulas
16399 ! have to be derived by power series expansion of the
16400 ! conventional formulas around 0 and 180.
16401 #ifdef PARINTDER
16402       do i=iphi1_start,iphi1_end
16403 #else
16404       do i=4,nres
16405 #endif
16406 !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16407 ! the conventional case
16408         sint=dsin(theta(i))
16409         sint1=dsin(theta(i-1))
16410         sing=dsin(phi(i))
16411         cost=dcos(theta(i))
16412         cost1=dcos(theta(i-1))
16413         cosg=dcos(phi(i))
16414         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16415         fac0=1.0d0/(sint1*sint)
16416         fac1=cost*fac0
16417         fac2=cost1*fac0
16418         fac3=cosg*cost1/(sint1*sint1)
16419         fac4=cosg*cost/(sint*sint)
16420 !    Obtaining the gamma derivatives from sine derivative
16421        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16422            phi(i).gt.pi34.and.phi(i).le.pi.or. &
16423            phi(i).ge.-pi.and.phi(i).le.-pi34) then
16424          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16425          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16426          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16427          do j=1,3
16428             ctgt=cost/sint
16429             ctgt1=cost1/sint1
16430             cosg_inv=1.0d0/cosg
16431             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16432             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16433               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16434             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16435             dsinphi(j,2,i)= &
16436               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16437               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16438             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16439             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16440               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16441 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16442             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16443             endif
16444 ! Bug fixed 3/24/05 (AL)
16445          enddo
16446 !   Obtaining the gamma derivatives from cosine derivative
16447         else
16448            do j=1,3
16449            if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16450            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16451            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16452            dc_norm(j,i-3))/vbld(i-2)
16453            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16454            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16455            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16456            dcostheta(j,1,i)
16457            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16458            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16459            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16460            dc_norm(j,i-1))/vbld(i)
16461            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16462            endif
16463          enddo
16464         endif
16465       enddo
16466 !alculate derivative of Tauangle
16467 #ifdef PARINTDER
16468       do i=itau_start,itau_end
16469 #else
16470       do i=3,nres
16471 !elwrite(iout,*) " vecpr",i,nres
16472 #endif
16473        if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16474 !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16475 !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16476 !c dtauangle(j,intertyp,dervityp,residue number)
16477 !c INTERTYP=1 SC...Ca...Ca..Ca
16478 ! the conventional case
16479         sint=dsin(theta(i))
16480         sint1=dsin(omicron(2,i-1))
16481         sing=dsin(tauangle(1,i))
16482         cost=dcos(theta(i))
16483         cost1=dcos(omicron(2,i-1))
16484         cosg=dcos(tauangle(1,i))
16485 !elwrite(iout,*) " vecpr5",i,nres
16486         do j=1,3
16487 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16488 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16489         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16490 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16491         enddo
16492         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16493         fac0=1.0d0/(sint1*sint)
16494         fac1=cost*fac0
16495         fac2=cost1*fac0
16496         fac3=cosg*cost1/(sint1*sint1)
16497         fac4=cosg*cost/(sint*sint)
16498 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16499 !    Obtaining the gamma derivatives from sine derivative
16500        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16501            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16502            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16503          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16504          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16505          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16506         do j=1,3
16507             ctgt=cost/sint
16508             ctgt1=cost1/sint1
16509             cosg_inv=1.0d0/cosg
16510             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16511        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16512        *vbld_inv(i-2+nres)
16513             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16514             dsintau(j,1,2,i)= &
16515               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16516               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16517 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16518             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16519 ! Bug fixed 3/24/05 (AL)
16520             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16521               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16522 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16523             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16524          enddo
16525 !   Obtaining the gamma derivatives from cosine derivative
16526         else
16527            do j=1,3
16528            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16529            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16530            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16531            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16532            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16533            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16534            dcostheta(j,1,i)
16535            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16536            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16537            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16538            dc_norm(j,i-1))/vbld(i)
16539            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16540 !         write (iout,*) "else",i
16541          enddo
16542         endif
16543 !        do k=1,3
16544 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16545 !        enddo
16546       enddo
16547 !C Second case Ca...Ca...Ca...SC
16548 #ifdef PARINTDER
16549       do i=itau_start,itau_end
16550 #else
16551       do i=4,nres
16552 #endif
16553        if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16554           (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16555 ! the conventional case
16556         sint=dsin(omicron(1,i))
16557         sint1=dsin(theta(i-1))
16558         sing=dsin(tauangle(2,i))
16559         cost=dcos(omicron(1,i))
16560         cost1=dcos(theta(i-1))
16561         cosg=dcos(tauangle(2,i))
16562 !        do j=1,3
16563 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16564 !        enddo
16565         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16566         fac0=1.0d0/(sint1*sint)
16567         fac1=cost*fac0
16568         fac2=cost1*fac0
16569         fac3=cosg*cost1/(sint1*sint1)
16570         fac4=cosg*cost/(sint*sint)
16571 !    Obtaining the gamma derivatives from sine derivative
16572        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16573            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16574            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16575          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16576          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16577          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16578         do j=1,3
16579             ctgt=cost/sint
16580             ctgt1=cost1/sint1
16581             cosg_inv=1.0d0/cosg
16582             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16583               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16584 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16585 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16586             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16587             dsintau(j,2,2,i)= &
16588               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16589               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16590 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16591 !     & sing*ctgt*domicron(j,1,2,i),
16592 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16593             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16594 ! Bug fixed 3/24/05 (AL)
16595             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16596              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16597 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16598             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16599          enddo
16600 !   Obtaining the gamma derivatives from cosine derivative
16601         else
16602            do j=1,3
16603            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16604            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16605            dc_norm(j,i-3))/vbld(i-2)
16606            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16607            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16608            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16609            dcosomicron(j,1,1,i)
16610            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16611            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16612            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16613            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16614            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16615 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16616          enddo
16617         endif
16618       enddo
16619
16620 !CC third case SC...Ca...Ca...SC
16621 #ifdef PARINTDER
16622
16623       do i=itau_start,itau_end
16624 #else
16625       do i=3,nres
16626 #endif
16627 ! the conventional case
16628       if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16629       (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16630         sint=dsin(omicron(1,i))
16631         sint1=dsin(omicron(2,i-1))
16632         sing=dsin(tauangle(3,i))
16633         cost=dcos(omicron(1,i))
16634         cost1=dcos(omicron(2,i-1))
16635         cosg=dcos(tauangle(3,i))
16636         do j=1,3
16637         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16638 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16639         enddo
16640         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16641         fac0=1.0d0/(sint1*sint)
16642         fac1=cost*fac0
16643         fac2=cost1*fac0
16644         fac3=cosg*cost1/(sint1*sint1)
16645         fac4=cosg*cost/(sint*sint)
16646 !    Obtaining the gamma derivatives from sine derivative
16647        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16648            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16649            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16650          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16651          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16652          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16653         do j=1,3
16654             ctgt=cost/sint
16655             ctgt1=cost1/sint1
16656             cosg_inv=1.0d0/cosg
16657             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16658               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16659               *vbld_inv(i-2+nres)
16660             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16661             dsintau(j,3,2,i)= &
16662               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16663               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16664             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16665 ! Bug fixed 3/24/05 (AL)
16666             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16667               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16668               *vbld_inv(i-1+nres)
16669 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16670             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16671          enddo
16672 !   Obtaining the gamma derivatives from cosine derivative
16673         else
16674            do j=1,3
16675            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16676            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16677            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16678            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16679            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16680            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16681            dcosomicron(j,1,1,i)
16682            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16683            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16684            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16685            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16686            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16687 !          write(iout,*) "else",i
16688          enddo
16689         endif
16690       enddo
16691
16692 #ifdef CRYST_SC
16693 !   Derivatives of side-chain angles alpha and omega
16694 #if defined(MPI) && defined(PARINTDER)
16695         do i=ibond_start,ibond_end
16696 #else
16697         do i=2,nres-1
16698 #endif
16699           if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16700              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16701              fac6=fac5/vbld(i)
16702              fac7=fac5*fac5
16703              fac8=fac5/vbld(i+1)
16704              fac9=fac5/vbld(i+nres)
16705              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16706              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16707              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16708              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16709              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16710              sina=sqrt(1-cosa*cosa)
16711              sino=dsin(omeg(i))
16712 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16713              do j=1,3
16714                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16715                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16716                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16717                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16718                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16719                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16720                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16721                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16722                 vbld(i+nres))
16723                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16724             enddo
16725 ! obtaining the derivatives of omega from sines
16726             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16727                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16728                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16729                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16730                dsin(theta(i+1)))
16731                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16732                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16733                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16734                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16735                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16736                coso_inv=1.0d0/dcos(omeg(i))
16737                do j=1,3
16738                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16739                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16740                  (sino*dc_norm(j,i-1))/vbld(i)
16741                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16742                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16743                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16744                  -sino*dc_norm(j,i)/vbld(i+1)
16745                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16746                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16747                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16748                  vbld(i+nres)
16749                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16750               enddo
16751            else
16752 !   obtaining the derivatives of omega from cosines
16753              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16754              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16755              fac12=fac10*sina
16756              fac13=fac12*fac12
16757              fac14=sina*sina
16758              do j=1,3
16759                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16760                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16761                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16762                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16763                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
16764                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
16765                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
16766                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
16767                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
16768                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
16769                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
16770                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
16771                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
16772                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
16773                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
16774             enddo
16775           endif
16776          else
16777            do j=1,3
16778              do k=1,3
16779                dalpha(k,j,i)=0.0d0
16780                domega(k,j,i)=0.0d0
16781              enddo
16782            enddo
16783          endif
16784        enddo
16785 #endif
16786 #if defined(MPI) && defined(PARINTDER)
16787       if (nfgtasks.gt.1) then
16788 #ifdef DEBUG
16789 !d      write (iout,*) "Gather dtheta"
16790 !d      call flush(iout)
16791       write (iout,*) "dtheta before gather"
16792       do i=1,nres
16793         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
16794       enddo
16795 #endif
16796       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
16797         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
16798         king,FG_COMM,IERROR)
16799 #ifdef DEBUG
16800 !d      write (iout,*) "Gather dphi"
16801 !d      call flush(iout)
16802       write (iout,*) "dphi before gather"
16803       do i=1,nres
16804         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
16805       enddo
16806 #endif
16807       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
16808         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
16809         king,FG_COMM,IERROR)
16810 !d      write (iout,*) "Gather dalpha"
16811 !d      call flush(iout)
16812 #ifdef CRYST_SC
16813       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
16814         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16815         king,FG_COMM,IERROR)
16816 !d      write (iout,*) "Gather domega"
16817 !d      call flush(iout)
16818       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
16819         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16820         king,FG_COMM,IERROR)
16821 #endif
16822       endif
16823 #endif
16824 #ifdef DEBUG
16825       write (iout,*) "dtheta after gather"
16826       do i=1,nres
16827         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
16828       enddo
16829       write (iout,*) "dphi after gather"
16830       do i=1,nres
16831         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
16832       enddo
16833       write (iout,*) "dalpha after gather"
16834       do i=1,nres
16835         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
16836       enddo
16837       write (iout,*) "domega after gather"
16838       do i=1,nres
16839         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
16840       enddo
16841 #endif
16842       return
16843       end subroutine intcartderiv
16844 !-----------------------------------------------------------------------------
16845       subroutine checkintcartgrad
16846 !      implicit real*8 (a-h,o-z)
16847 !      include 'DIMENSIONS'
16848 #ifdef MPI
16849       include 'mpif.h'
16850 #endif
16851 !      include 'COMMON.CHAIN'
16852 !      include 'COMMON.VAR'
16853 !      include 'COMMON.GEO'
16854 !      include 'COMMON.INTERACT'
16855 !      include 'COMMON.DERIV'
16856 !      include 'COMMON.IOUNITS'
16857 !      include 'COMMON.SETUP'
16858       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
16859       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
16860       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
16861       real(kind=8),dimension(3) :: dc_norm_s
16862       real(kind=8) :: aincr=1.0d-5
16863       integer :: i,j
16864       real(kind=8) :: dcji
16865       do i=1,nres
16866         phi_s(i)=phi(i)
16867         theta_s(i)=theta(i)
16868         alph_s(i)=alph(i)
16869         omeg_s(i)=omeg(i)
16870       enddo
16871 ! Check theta gradient
16872       write (iout,*) &
16873        "Analytical (upper) and numerical (lower) gradient of theta"
16874       write (iout,*)
16875       do i=3,nres
16876         do j=1,3
16877           dcji=dc(j,i-2)
16878           dc(j,i-2)=dcji+aincr
16879           call chainbuild_cart
16880           call int_from_cart1(.false.)
16881           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
16882           dc(j,i-2)=dcji
16883           dcji=dc(j,i-1)
16884           dc(j,i-1)=dc(j,i-1)+aincr
16885           call chainbuild_cart
16886           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
16887           dc(j,i-1)=dcji
16888         enddo
16889 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
16890 !el          (dtheta(j,2,i),j=1,3)
16891 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
16892 !el          (dthetanum(j,2,i),j=1,3)
16893 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
16894 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
16895 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
16896 !el        write (iout,*)
16897       enddo
16898 ! Check gamma gradient
16899       write (iout,*) &
16900        "Analytical (upper) and numerical (lower) gradient of gamma"
16901       do i=4,nres
16902         do j=1,3
16903           dcji=dc(j,i-3)
16904           dc(j,i-3)=dcji+aincr
16905           call chainbuild_cart
16906           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
16907           dc(j,i-3)=dcji
16908           dcji=dc(j,i-2)
16909           dc(j,i-2)=dcji+aincr
16910           call chainbuild_cart
16911           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
16912           dc(j,i-2)=dcji
16913           dcji=dc(j,i-1)
16914           dc(j,i-1)=dc(j,i-1)+aincr
16915           call chainbuild_cart
16916           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
16917           dc(j,i-1)=dcji
16918         enddo
16919 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
16920 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
16921 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
16922 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
16923 !el        write (iout,'(5x,3(3f10.5,5x))') &
16924 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
16925 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
16926 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
16927 !el        write (iout,*)
16928       enddo
16929 ! Check alpha gradient
16930       write (iout,*) &
16931        "Analytical (upper) and numerical (lower) gradient of alpha"
16932       do i=2,nres-1
16933        if(itype(i,1).ne.10) then
16934             do j=1,3
16935               dcji=dc(j,i-1)
16936               dc(j,i-1)=dcji+aincr
16937               call chainbuild_cart
16938               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
16939               /aincr
16940               dc(j,i-1)=dcji
16941               dcji=dc(j,i)
16942               dc(j,i)=dcji+aincr
16943               call chainbuild_cart
16944               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
16945               /aincr
16946               dc(j,i)=dcji
16947               dcji=dc(j,i+nres)
16948               dc(j,i+nres)=dc(j,i+nres)+aincr
16949               call chainbuild_cart
16950               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
16951               /aincr
16952              dc(j,i+nres)=dcji
16953             enddo
16954           endif
16955 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
16956 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
16957 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
16958 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
16959 !el        write (iout,'(5x,3(3f10.5,5x))') &
16960 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
16961 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
16962 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
16963 !el        write (iout,*)
16964       enddo
16965 !     Check omega gradient
16966       write (iout,*) &
16967        "Analytical (upper) and numerical (lower) gradient of omega"
16968       do i=2,nres-1
16969        if(itype(i,1).ne.10) then
16970             do j=1,3
16971               dcji=dc(j,i-1)
16972               dc(j,i-1)=dcji+aincr
16973               call chainbuild_cart
16974               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
16975               /aincr
16976               dc(j,i-1)=dcji
16977               dcji=dc(j,i)
16978               dc(j,i)=dcji+aincr
16979               call chainbuild_cart
16980               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
16981               /aincr
16982               dc(j,i)=dcji
16983               dcji=dc(j,i+nres)
16984               dc(j,i+nres)=dc(j,i+nres)+aincr
16985               call chainbuild_cart
16986               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
16987               /aincr
16988              dc(j,i+nres)=dcji
16989             enddo
16990           endif
16991 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
16992 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
16993 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
16994 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
16995 !el        write (iout,'(5x,3(3f10.5,5x))') &
16996 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
16997 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
16998 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
16999 !el        write (iout,*)
17000       enddo
17001       return
17002       end subroutine checkintcartgrad
17003 !-----------------------------------------------------------------------------
17004 ! q_measure.F
17005 !-----------------------------------------------------------------------------
17006       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17007 !      implicit real*8 (a-h,o-z)
17008 !      include 'DIMENSIONS'
17009 !      include 'COMMON.IOUNITS'
17010 !      include 'COMMON.CHAIN'
17011 !      include 'COMMON.INTERACT'
17012 !      include 'COMMON.VAR'
17013       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17014       integer :: kkk,nsep=3
17015       real(kind=8) :: qm        !dist,
17016       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17017       logical :: lprn=.false.
17018       logical :: flag
17019 !      real(kind=8) :: sigm,x
17020
17021 !el      sigm(x)=0.25d0*x     ! local function
17022       qqmax=1.0d10
17023       do kkk=1,nperm
17024       qq = 0.0d0
17025       nl=0
17026        if(flag) then
17027         do il=seg1+nsep,seg2
17028           do jl=seg1,il-nsep
17029             nl=nl+1
17030             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17031                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17032                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17033             dij=dist(il,jl)
17034             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17035             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17036               nl=nl+1
17037               d0ijCM=dsqrt( &
17038                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17039                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17040                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17041               dijCM=dist(il+nres,jl+nres)
17042               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17043             endif
17044             qq = qq+qqij+qqijCM
17045           enddo
17046         enddo
17047         qq = qq/nl
17048       else
17049       do il=seg1,seg2
17050         if((seg3-il).lt.3) then
17051              secseg=il+3
17052         else
17053              secseg=seg3
17054         endif
17055           do jl=secseg,seg4
17056             nl=nl+1
17057             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17058                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17059                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17060             dij=dist(il,jl)
17061             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17062             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17063               nl=nl+1
17064               d0ijCM=dsqrt( &
17065                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17066                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17067                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17068               dijCM=dist(il+nres,jl+nres)
17069               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17070             endif
17071             qq = qq+qqij+qqijCM
17072           enddo
17073         enddo
17074       qq = qq/nl
17075       endif
17076       if (qqmax.le.qq) qqmax=qq
17077       enddo
17078       qwolynes=1.0d0-qqmax
17079       return
17080       end function qwolynes
17081 !-----------------------------------------------------------------------------
17082       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17083 !      implicit real*8 (a-h,o-z)
17084 !      include 'DIMENSIONS'
17085 !      include 'COMMON.IOUNITS'
17086 !      include 'COMMON.CHAIN'
17087 !      include 'COMMON.INTERACT'
17088 !      include 'COMMON.VAR'
17089 !      include 'COMMON.MD'
17090       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17091       integer :: nsep=3, kkk
17092 !el      real(kind=8) :: dist
17093       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17094       logical :: lprn=.false.
17095       logical :: flag
17096       real(kind=8) :: sim,dd0,fac,ddqij
17097 !el      sigm(x)=0.25d0*x            ! local function
17098       do kkk=1,nperm
17099       do i=0,nres
17100         do j=1,3
17101           dqwol(j,i)=0.0d0
17102           dxqwol(j,i)=0.0d0
17103         enddo
17104       enddo
17105       nl=0
17106        if(flag) then
17107         do il=seg1+nsep,seg2
17108           do jl=seg1,il-nsep
17109             nl=nl+1
17110             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17111                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17112                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17113             dij=dist(il,jl)
17114             sim = 1.0d0/sigm(d0ij)
17115             sim = sim*sim
17116             dd0 = dij-d0ij
17117             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17118             do k=1,3
17119               ddqij = (c(k,il)-c(k,jl))*fac
17120               dqwol(k,il)=dqwol(k,il)+ddqij
17121               dqwol(k,jl)=dqwol(k,jl)-ddqij
17122             enddo
17123
17124             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17125               nl=nl+1
17126               d0ijCM=dsqrt( &
17127                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17128                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17129                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17130               dijCM=dist(il+nres,jl+nres)
17131               sim = 1.0d0/sigm(d0ijCM)
17132               sim = sim*sim
17133               dd0=dijCM-d0ijCM
17134               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17135               do k=1,3
17136                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17137                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17138                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17139               enddo
17140             endif
17141           enddo
17142         enddo
17143        else
17144         do il=seg1,seg2
17145         if((seg3-il).lt.3) then
17146              secseg=il+3
17147         else
17148              secseg=seg3
17149         endif
17150           do jl=secseg,seg4
17151             nl=nl+1
17152             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17153                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17154                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17155             dij=dist(il,jl)
17156             sim = 1.0d0/sigm(d0ij)
17157             sim = sim*sim
17158             dd0 = dij-d0ij
17159             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17160             do k=1,3
17161               ddqij = (c(k,il)-c(k,jl))*fac
17162               dqwol(k,il)=dqwol(k,il)+ddqij
17163               dqwol(k,jl)=dqwol(k,jl)-ddqij
17164             enddo
17165             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17166               nl=nl+1
17167               d0ijCM=dsqrt( &
17168                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17169                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17170                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17171               dijCM=dist(il+nres,jl+nres)
17172               sim = 1.0d0/sigm(d0ijCM)
17173               sim=sim*sim
17174               dd0 = dijCM-d0ijCM
17175               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17176               do k=1,3
17177                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17178                dxqwol(k,il)=dxqwol(k,il)+ddqij
17179                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17180               enddo
17181             endif
17182           enddo
17183         enddo
17184       endif
17185       enddo
17186        do i=0,nres
17187          do j=1,3
17188            dqwol(j,i)=dqwol(j,i)/nl
17189            dxqwol(j,i)=dxqwol(j,i)/nl
17190          enddo
17191        enddo
17192       return
17193       end subroutine qwolynes_prim
17194 !-----------------------------------------------------------------------------
17195       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17196 !      implicit real*8 (a-h,o-z)
17197 !      include 'DIMENSIONS'
17198 !      include 'COMMON.IOUNITS'
17199 !      include 'COMMON.CHAIN'
17200 !      include 'COMMON.INTERACT'
17201 !      include 'COMMON.VAR'
17202       integer :: seg1,seg2,seg3,seg4
17203       logical :: flag
17204       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17205       real(kind=8),dimension(3,0:2*nres) :: cdummy
17206       real(kind=8) :: q1,q2
17207       real(kind=8) :: delta=1.0d-10
17208       integer :: i,j
17209
17210       do i=0,nres
17211         do j=1,3
17212           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17213           cdummy(j,i)=c(j,i)
17214           c(j,i)=c(j,i)+delta
17215           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17216           qwolan(j,i)=(q2-q1)/delta
17217           c(j,i)=cdummy(j,i)
17218         enddo
17219       enddo
17220       do i=0,nres
17221         do j=1,3
17222           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17223           cdummy(j,i+nres)=c(j,i+nres)
17224           c(j,i+nres)=c(j,i+nres)+delta
17225           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17226           qwolxan(j,i)=(q2-q1)/delta
17227           c(j,i+nres)=cdummy(j,i+nres)
17228         enddo
17229       enddo
17230 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17231 !      do i=0,nct
17232 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17233 !      enddo
17234 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17235 !      do i=0,nct
17236 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17237 !      enddo
17238       return
17239       end subroutine qwol_num
17240 !-----------------------------------------------------------------------------
17241       subroutine EconstrQ
17242 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17243 !      implicit real*8 (a-h,o-z)
17244 !      include 'DIMENSIONS'
17245 !      include 'COMMON.CONTROL'
17246 !      include 'COMMON.VAR'
17247 !      include 'COMMON.MD'
17248       use MD_data
17249 !#ifndef LANG0
17250 !      include 'COMMON.LANGEVIN'
17251 !#else
17252 !      include 'COMMON.LANGEVIN.lang0'
17253 !#endif
17254 !      include 'COMMON.CHAIN'
17255 !      include 'COMMON.DERIV'
17256 !      include 'COMMON.GEO'
17257 !      include 'COMMON.LOCAL'
17258 !      include 'COMMON.INTERACT'
17259 !      include 'COMMON.IOUNITS'
17260 !      include 'COMMON.NAMES'
17261 !      include 'COMMON.TIME1'
17262       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17263       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17264                    duconst,duxconst
17265       integer :: kstart,kend,lstart,lend,idummy
17266       real(kind=8) :: delta=1.0d-7
17267       integer :: i,j,k,ii
17268       do i=0,nres
17269          do j=1,3
17270             duconst(j,i)=0.0d0
17271             dudconst(j,i)=0.0d0
17272             duxconst(j,i)=0.0d0
17273             dudxconst(j,i)=0.0d0
17274          enddo
17275       enddo
17276       Uconst=0.0d0
17277       do i=1,nfrag
17278          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17279            idummy,idummy)
17280          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17281 ! Calculating the derivatives of Constraint energy with respect to Q
17282          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17283            qinfrag(i,iset))
17284 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17285 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17286 !         hmnum=(hm2-hm1)/delta
17287 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17288 !     &   qinfrag(i,iset))
17289 !         write(iout,*) "harmonicnum frag", hmnum
17290 ! Calculating the derivatives of Q with respect to cartesian coordinates
17291          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17292           idummy,idummy)
17293 !         write(iout,*) "dqwol "
17294 !         do ii=1,nres
17295 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17296 !         enddo
17297 !         write(iout,*) "dxqwol "
17298 !         do ii=1,nres
17299 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17300 !         enddo
17301 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17302 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17303 !     &  ,idummy,idummy)
17304 !  The gradients of Uconst in Cs
17305          do ii=0,nres
17306             do j=1,3
17307                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17308                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17309             enddo
17310          enddo
17311       enddo
17312       do i=1,npair
17313          kstart=ifrag(1,ipair(1,i,iset),iset)
17314          kend=ifrag(2,ipair(1,i,iset),iset)
17315          lstart=ifrag(1,ipair(2,i,iset),iset)
17316          lend=ifrag(2,ipair(2,i,iset),iset)
17317          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17318          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17319 !  Calculating dU/dQ
17320          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17321 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17322 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17323 !         hmnum=(hm2-hm1)/delta
17324 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17325 !     &   qinpair(i,iset))
17326 !         write(iout,*) "harmonicnum pair ", hmnum
17327 ! Calculating dQ/dXi
17328          call qwolynes_prim(kstart,kend,.false.,&
17329           lstart,lend)
17330 !         write(iout,*) "dqwol "
17331 !         do ii=1,nres
17332 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17333 !         enddo
17334 !         write(iout,*) "dxqwol "
17335 !         do ii=1,nres
17336 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17337 !        enddo
17338 ! Calculating numerical gradients
17339 !        call qwol_num(kstart,kend,.false.
17340 !     &  ,lstart,lend)
17341 ! The gradients of Uconst in Cs
17342          do ii=0,nres
17343             do j=1,3
17344                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17345                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17346             enddo
17347          enddo
17348       enddo
17349 !      write(iout,*) "Uconst inside subroutine ", Uconst
17350 ! Transforming the gradients from Cs to dCs for the backbone
17351       do i=0,nres
17352          do j=i+1,nres
17353            do k=1,3
17354              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17355            enddo
17356          enddo
17357       enddo
17358 !  Transforming the gradients from Cs to dCs for the side chains
17359       do i=1,nres
17360          do j=1,3
17361            dudxconst(j,i)=duxconst(j,i)
17362          enddo
17363       enddo
17364 !      write(iout,*) "dU/ddc backbone "
17365 !       do ii=0,nres
17366 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17367 !      enddo
17368 !      write(iout,*) "dU/ddX side chain "
17369 !      do ii=1,nres
17370 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17371 !      enddo
17372 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17373 !      call dEconstrQ_num
17374       return
17375       end subroutine EconstrQ
17376 !-----------------------------------------------------------------------------
17377       subroutine dEconstrQ_num
17378 ! Calculating numerical dUconst/ddc and dUconst/ddx
17379 !      implicit real*8 (a-h,o-z)
17380 !      include 'DIMENSIONS'
17381 !      include 'COMMON.CONTROL'
17382 !      include 'COMMON.VAR'
17383 !      include 'COMMON.MD'
17384       use MD_data
17385 !#ifndef LANG0
17386 !      include 'COMMON.LANGEVIN'
17387 !#else
17388 !      include 'COMMON.LANGEVIN.lang0'
17389 !#endif
17390 !      include 'COMMON.CHAIN'
17391 !      include 'COMMON.DERIV'
17392 !      include 'COMMON.GEO'
17393 !      include 'COMMON.LOCAL'
17394 !      include 'COMMON.INTERACT'
17395 !      include 'COMMON.IOUNITS'
17396 !      include 'COMMON.NAMES'
17397 !      include 'COMMON.TIME1'
17398       real(kind=8) :: uzap1,uzap2
17399       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17400       integer :: kstart,kend,lstart,lend,idummy
17401       real(kind=8) :: delta=1.0d-7
17402 !el local variables
17403       integer :: i,ii,j
17404 !     real(kind=8) ::
17405 !     For the backbone
17406       do i=0,nres-1
17407          do j=1,3
17408             dUcartan(j,i)=0.0d0
17409             cdummy(j,i)=dc(j,i)
17410             dc(j,i)=dc(j,i)+delta
17411             call chainbuild_cart
17412             uzap2=0.0d0
17413             do ii=1,nfrag
17414              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17415                 idummy,idummy)
17416                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17417                 qinfrag(ii,iset))
17418             enddo
17419             do ii=1,npair
17420                kstart=ifrag(1,ipair(1,ii,iset),iset)
17421                kend=ifrag(2,ipair(1,ii,iset),iset)
17422                lstart=ifrag(1,ipair(2,ii,iset),iset)
17423                lend=ifrag(2,ipair(2,ii,iset),iset)
17424                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17425                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17426                  qinpair(ii,iset))
17427             enddo
17428             dc(j,i)=cdummy(j,i)
17429             call chainbuild_cart
17430             uzap1=0.0d0
17431              do ii=1,nfrag
17432              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17433                 idummy,idummy)
17434                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17435                 qinfrag(ii,iset))
17436             enddo
17437             do ii=1,npair
17438                kstart=ifrag(1,ipair(1,ii,iset),iset)
17439                kend=ifrag(2,ipair(1,ii,iset),iset)
17440                lstart=ifrag(1,ipair(2,ii,iset),iset)
17441                lend=ifrag(2,ipair(2,ii,iset),iset)
17442                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17443                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17444                 qinpair(ii,iset))
17445             enddo
17446             ducartan(j,i)=(uzap2-uzap1)/(delta)
17447          enddo
17448       enddo
17449 ! Calculating numerical gradients for dU/ddx
17450       do i=0,nres-1
17451          duxcartan(j,i)=0.0d0
17452          do j=1,3
17453             cdummy(j,i)=dc(j,i+nres)
17454             dc(j,i+nres)=dc(j,i+nres)+delta
17455             call chainbuild_cart
17456             uzap2=0.0d0
17457             do ii=1,nfrag
17458              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17459                 idummy,idummy)
17460                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17461                 qinfrag(ii,iset))
17462             enddo
17463             do ii=1,npair
17464                kstart=ifrag(1,ipair(1,ii,iset),iset)
17465                kend=ifrag(2,ipair(1,ii,iset),iset)
17466                lstart=ifrag(1,ipair(2,ii,iset),iset)
17467                lend=ifrag(2,ipair(2,ii,iset),iset)
17468                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17469                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17470                 qinpair(ii,iset))
17471             enddo
17472             dc(j,i+nres)=cdummy(j,i)
17473             call chainbuild_cart
17474             uzap1=0.0d0
17475              do ii=1,nfrag
17476                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17477                 ifrag(2,ii,iset),.true.,idummy,idummy)
17478                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17479                 qinfrag(ii,iset))
17480             enddo
17481             do ii=1,npair
17482                kstart=ifrag(1,ipair(1,ii,iset),iset)
17483                kend=ifrag(2,ipair(1,ii,iset),iset)
17484                lstart=ifrag(1,ipair(2,ii,iset),iset)
17485                lend=ifrag(2,ipair(2,ii,iset),iset)
17486                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17487                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17488                 qinpair(ii,iset))
17489             enddo
17490             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17491          enddo
17492       enddo
17493       write(iout,*) "Numerical dUconst/ddc backbone "
17494       do ii=0,nres
17495         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17496       enddo
17497 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17498 !      do ii=1,nres
17499 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17500 !      enddo
17501       return
17502       end subroutine dEconstrQ_num
17503 !-----------------------------------------------------------------------------
17504 ! ssMD.F
17505 !-----------------------------------------------------------------------------
17506       subroutine check_energies
17507
17508 !      use random, only: ran_number
17509
17510 !      implicit none
17511 !     Includes
17512 !      include 'DIMENSIONS'
17513 !      include 'COMMON.CHAIN'
17514 !      include 'COMMON.VAR'
17515 !      include 'COMMON.IOUNITS'
17516 !      include 'COMMON.SBRIDGE'
17517 !      include 'COMMON.LOCAL'
17518 !      include 'COMMON.GEO'
17519
17520 !     External functions
17521 !EL      double precision ran_number
17522 !EL      external ran_number
17523
17524 !     Local variables
17525       integer :: i,j,k,l,lmax,p,pmax
17526       real(kind=8) :: rmin,rmax
17527       real(kind=8) :: eij
17528
17529       real(kind=8) :: d
17530       real(kind=8) :: wi,rij,tj,pj
17531 !      return
17532
17533       i=5
17534       j=14
17535
17536       d=dsc(1)
17537       rmin=2.0D0
17538       rmax=12.0D0
17539
17540       lmax=10000
17541       pmax=1
17542
17543       do k=1,3
17544         c(k,i)=0.0D0
17545         c(k,j)=0.0D0
17546         c(k,nres+i)=0.0D0
17547         c(k,nres+j)=0.0D0
17548       enddo
17549
17550       do l=1,lmax
17551
17552 !t        wi=ran_number(0.0D0,pi)
17553 !        wi=ran_number(0.0D0,pi/6.0D0)
17554 !        wi=0.0D0
17555 !t        tj=ran_number(0.0D0,pi)
17556 !t        pj=ran_number(0.0D0,pi)
17557 !        pj=ran_number(0.0D0,pi/6.0D0)
17558 !        pj=0.0D0
17559
17560         do p=1,pmax
17561 !t           rij=ran_number(rmin,rmax)
17562
17563            c(1,j)=d*sin(pj)*cos(tj)
17564            c(2,j)=d*sin(pj)*sin(tj)
17565            c(3,j)=d*cos(pj)
17566
17567            c(3,nres+i)=-rij
17568
17569            c(1,i)=d*sin(wi)
17570            c(3,i)=-rij-d*cos(wi)
17571
17572            do k=1,3
17573               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17574               dc_norm(k,nres+i)=dc(k,nres+i)/d
17575               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17576               dc_norm(k,nres+j)=dc(k,nres+j)/d
17577            enddo
17578
17579            call dyn_ssbond_ene(i,j,eij)
17580         enddo
17581       enddo
17582       call exit(1)
17583       return
17584       end subroutine check_energies
17585 !-----------------------------------------------------------------------------
17586       subroutine dyn_ssbond_ene(resi,resj,eij)
17587 !      implicit none
17588 !      Includes
17589       use calc_data
17590       use comm_sschecks
17591 !      include 'DIMENSIONS'
17592 !      include 'COMMON.SBRIDGE'
17593 !      include 'COMMON.CHAIN'
17594 !      include 'COMMON.DERIV'
17595 !      include 'COMMON.LOCAL'
17596 !      include 'COMMON.INTERACT'
17597 !      include 'COMMON.VAR'
17598 !      include 'COMMON.IOUNITS'
17599 !      include 'COMMON.CALC'
17600 #ifndef CLUST
17601 #ifndef WHAM
17602        use MD_data
17603 !      include 'COMMON.MD'
17604 !      use MD, only: totT,t_bath
17605 #endif
17606 #endif
17607 !     External functions
17608 !EL      double precision h_base
17609 !EL      external h_base
17610
17611 !     Input arguments
17612       integer :: resi,resj
17613
17614 !     Output arguments
17615       real(kind=8) :: eij
17616
17617 !     Local variables
17618       logical :: havebond
17619       integer itypi,itypj
17620       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17621       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17622       real(kind=8),dimension(3) :: dcosom1,dcosom2
17623       real(kind=8) :: ed
17624       real(kind=8) :: pom1,pom2
17625       real(kind=8) :: ljA,ljB,ljXs
17626       real(kind=8),dimension(1:3) :: d_ljB
17627       real(kind=8) :: ssA,ssB,ssC,ssXs
17628       real(kind=8) :: ssxm,ljxm,ssm,ljm
17629       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17630       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17631       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17632 !-------FIRST METHOD
17633       real(kind=8) :: xm
17634       real(kind=8),dimension(1:3) :: d_xm
17635 !-------END FIRST METHOD
17636 !-------SECOND METHOD
17637 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17638 !-------END SECOND METHOD
17639
17640 !-------TESTING CODE
17641 !el      logical :: checkstop,transgrad
17642 !el      common /sschecks/ checkstop,transgrad
17643
17644       integer :: icheck,nicheck,jcheck,njcheck
17645       real(kind=8),dimension(-1:1) :: echeck
17646       real(kind=8) :: deps,ssx0,ljx0
17647 !-------END TESTING CODE
17648
17649       eij=0.0d0
17650       i=resi
17651       j=resj
17652
17653 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17654 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17655
17656       itypi=itype(i,1)
17657       dxi=dc_norm(1,nres+i)
17658       dyi=dc_norm(2,nres+i)
17659       dzi=dc_norm(3,nres+i)
17660       dsci_inv=vbld_inv(i+nres)
17661
17662       itypj=itype(j,1)
17663       xj=c(1,nres+j)-c(1,nres+i)
17664       yj=c(2,nres+j)-c(2,nres+i)
17665       zj=c(3,nres+j)-c(3,nres+i)
17666       dxj=dc_norm(1,nres+j)
17667       dyj=dc_norm(2,nres+j)
17668       dzj=dc_norm(3,nres+j)
17669       dscj_inv=vbld_inv(j+nres)
17670
17671       chi1=chi(itypi,itypj)
17672       chi2=chi(itypj,itypi)
17673       chi12=chi1*chi2
17674       chip1=chip(itypi)
17675       chip2=chip(itypj)
17676       chip12=chip1*chip2
17677       alf1=alp(itypi)
17678       alf2=alp(itypj)
17679       alf12=0.5D0*(alf1+alf2)
17680
17681       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17682       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17683 !     The following are set in sc_angular
17684 !      erij(1)=xj*rij
17685 !      erij(2)=yj*rij
17686 !      erij(3)=zj*rij
17687 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17688 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17689 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17690       call sc_angular
17691       rij=1.0D0/rij  ! Reset this so it makes sense
17692
17693       sig0ij=sigma(itypi,itypj)
17694       sig=sig0ij*dsqrt(1.0D0/sigsq)
17695
17696       ljXs=sig-sig0ij
17697       ljA=eps1*eps2rt**2*eps3rt**2
17698       ljB=ljA*bb_aq(itypi,itypj)
17699       ljA=ljA*aa_aq(itypi,itypj)
17700       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17701
17702       ssXs=d0cm
17703       deltat1=1.0d0-om1
17704       deltat2=1.0d0+om2
17705       deltat12=om2-om1+2.0d0
17706       cosphi=om12-om1*om2
17707       ssA=akcm
17708       ssB=akct*deltat12
17709       ssC=ss_depth &
17710            +akth*(deltat1*deltat1+deltat2*deltat2) &
17711            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17712       ssxm=ssXs-0.5D0*ssB/ssA
17713
17714 !-------TESTING CODE
17715 !$$$c     Some extra output
17716 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17717 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17718 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17719 !$$$      if (ssx0.gt.0.0d0) then
17720 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17721 !$$$      else
17722 !$$$        ssx0=ssxm
17723 !$$$      endif
17724 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17725 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17726 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17727 !$$$      return
17728 !-------END TESTING CODE
17729
17730 !-------TESTING CODE
17731 !     Stop and plot energy and derivative as a function of distance
17732       if (checkstop) then
17733         ssm=ssC-0.25D0*ssB*ssB/ssA
17734         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17735         if (ssm.lt.ljm .and. &
17736              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17737           nicheck=1000
17738           njcheck=1
17739           deps=0.5d-7
17740         else
17741           checkstop=.false.
17742         endif
17743       endif
17744       if (.not.checkstop) then
17745         nicheck=0
17746         njcheck=-1
17747       endif
17748
17749       do icheck=0,nicheck
17750       do jcheck=-1,njcheck
17751       if (checkstop) rij=(ssxm-1.0d0)+ &
17752              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17753 !-------END TESTING CODE
17754
17755       if (rij.gt.ljxm) then
17756         havebond=.false.
17757         ljd=rij-ljXs
17758         fac=(1.0D0/ljd)**expon
17759         e1=fac*fac*aa_aq(itypi,itypj)
17760         e2=fac*bb_aq(itypi,itypj)
17761         eij=eps1*eps2rt*eps3rt*(e1+e2)
17762         eps2der=eij*eps3rt
17763         eps3der=eij*eps2rt
17764         eij=eij*eps2rt*eps3rt
17765
17766         sigder=-sig/sigsq
17767         e1=e1*eps1*eps2rt**2*eps3rt**2
17768         ed=-expon*(e1+eij)/ljd
17769         sigder=ed*sigder
17770         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17771         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17772         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
17773              -2.0D0*alf12*eps3der+sigder*sigsq_om12
17774       else if (rij.lt.ssxm) then
17775         havebond=.true.
17776         ssd=rij-ssXs
17777         eij=ssA*ssd*ssd+ssB*ssd+ssC
17778
17779         ed=2*akcm*ssd+akct*deltat12
17780         pom1=akct*ssd
17781         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
17782         eom1=-2*akth*deltat1-pom1-om2*pom2
17783         eom2= 2*akth*deltat2+pom1-om1*pom2
17784         eom12=pom2
17785       else
17786         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
17787
17788         d_ssxm(1)=0.5D0*akct/ssA
17789         d_ssxm(2)=-d_ssxm(1)
17790         d_ssxm(3)=0.0D0
17791
17792         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
17793         d_ljxm(2)=d_ljxm(1)*sigsq_om2
17794         d_ljxm(3)=d_ljxm(1)*sigsq_om12
17795         d_ljxm(1)=d_ljxm(1)*sigsq_om1
17796
17797 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17798         xm=0.5d0*(ssxm+ljxm)
17799         do k=1,3
17800           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
17801         enddo
17802         if (rij.lt.xm) then
17803           havebond=.true.
17804           ssm=ssC-0.25D0*ssB*ssB/ssA
17805           d_ssm(1)=0.5D0*akct*ssB/ssA
17806           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17807           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17808           d_ssm(3)=omega
17809           f1=(rij-xm)/(ssxm-xm)
17810           f2=(rij-ssxm)/(xm-ssxm)
17811           h1=h_base(f1,hd1)
17812           h2=h_base(f2,hd2)
17813           eij=ssm*h1+Ht*h2
17814           delta_inv=1.0d0/(xm-ssxm)
17815           deltasq_inv=delta_inv*delta_inv
17816           fac=ssm*hd1-Ht*hd2
17817           fac1=deltasq_inv*fac*(xm-rij)
17818           fac2=deltasq_inv*fac*(rij-ssxm)
17819           ed=delta_inv*(Ht*hd2-ssm*hd1)
17820           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
17821           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
17822           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
17823         else
17824           havebond=.false.
17825           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17826           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
17827           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
17828           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
17829                alf12/eps3rt)
17830           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
17831           f1=(rij-ljxm)/(xm-ljxm)
17832           f2=(rij-xm)/(ljxm-xm)
17833           h1=h_base(f1,hd1)
17834           h2=h_base(f2,hd2)
17835           eij=Ht*h1+ljm*h2
17836           delta_inv=1.0d0/(ljxm-xm)
17837           deltasq_inv=delta_inv*delta_inv
17838           fac=Ht*hd1-ljm*hd2
17839           fac1=deltasq_inv*fac*(ljxm-rij)
17840           fac2=deltasq_inv*fac*(rij-xm)
17841           ed=delta_inv*(ljm*hd2-Ht*hd1)
17842           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
17843           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
17844           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
17845         endif
17846 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17847
17848 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17849 !$$$        ssd=rij-ssXs
17850 !$$$        ljd=rij-ljXs
17851 !$$$        fac1=rij-ljxm
17852 !$$$        fac2=rij-ssxm
17853 !$$$
17854 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
17855 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
17856 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
17857 !$$$
17858 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
17859 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
17860 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17861 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17862 !$$$        d_ssm(3)=omega
17863 !$$$
17864 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
17865 !$$$        do k=1,3
17866 !$$$          d_ljm(k)=ljm*d_ljB(k)
17867 !$$$        enddo
17868 !$$$        ljm=ljm*ljB
17869 !$$$
17870 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
17871 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
17872 !$$$        d_ss(2)=akct*ssd
17873 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
17874 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
17875 !$$$        d_ss(3)=omega
17876 !$$$
17877 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
17878 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
17879 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
17880 !$$$        do k=1,3
17881 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
17882 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
17883 !$$$        enddo
17884 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
17885 !$$$
17886 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
17887 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
17888 !$$$        h1=h_base(f1,hd1)
17889 !$$$        h2=h_base(f2,hd2)
17890 !$$$        eij=ss*h1+ljf*h2
17891 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
17892 !$$$        deltasq_inv=delta_inv*delta_inv
17893 !$$$        fac=ljf*hd2-ss*hd1
17894 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
17895 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
17896 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
17897 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
17898 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
17899 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
17900 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
17901 !$$$
17902 !$$$        havebond=.false.
17903 !$$$        if (ed.gt.0.0d0) havebond=.true.
17904 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17905
17906       endif
17907
17908       if (havebond) then
17909 !#ifndef CLUST
17910 !#ifndef WHAM
17911 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
17912 !          write(iout,'(a15,f12.2,f8.1,2i5)')
17913 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
17914 !        endif
17915 !#endif
17916 !#endif
17917         dyn_ssbond_ij(i,j)=eij
17918       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
17919         dyn_ssbond_ij(i,j)=1.0d300
17920 !#ifndef CLUST
17921 !#ifndef WHAM
17922 !        write(iout,'(a15,f12.2,f8.1,2i5)')
17923 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
17924 !#endif
17925 !#endif
17926       endif
17927
17928 !-------TESTING CODE
17929 !el      if (checkstop) then
17930         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
17931              "CHECKSTOP",rij,eij,ed
17932         echeck(jcheck)=eij
17933 !el      endif
17934       enddo
17935       if (checkstop) then
17936         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
17937       endif
17938       enddo
17939       if (checkstop) then
17940         transgrad=.true.
17941         checkstop=.false.
17942       endif
17943 !-------END TESTING CODE
17944
17945       do k=1,3
17946         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
17947         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
17948       enddo
17949       do k=1,3
17950         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
17951       enddo
17952       do k=1,3
17953         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
17954              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
17955              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
17956         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
17957              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
17958              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
17959       enddo
17960 !grad      do k=i,j-1
17961 !grad        do l=1,3
17962 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
17963 !grad        enddo
17964 !grad      enddo
17965
17966       do l=1,3
17967         gvdwc(l,i)=gvdwc(l,i)-gg(l)
17968         gvdwc(l,j)=gvdwc(l,j)+gg(l)
17969       enddo
17970
17971       return
17972       end subroutine dyn_ssbond_ene
17973 !--------------------------------------------------------------------------
17974          subroutine triple_ssbond_ene(resi,resj,resk,eij)
17975 !      implicit none
17976 !      Includes
17977       use calc_data
17978       use comm_sschecks
17979 !      include 'DIMENSIONS'
17980 !      include 'COMMON.SBRIDGE'
17981 !      include 'COMMON.CHAIN'
17982 !      include 'COMMON.DERIV'
17983 !      include 'COMMON.LOCAL'
17984 !      include 'COMMON.INTERACT'
17985 !      include 'COMMON.VAR'
17986 !      include 'COMMON.IOUNITS'
17987 !      include 'COMMON.CALC'
17988 #ifndef CLUST
17989 #ifndef WHAM
17990        use MD_data
17991 !      include 'COMMON.MD'
17992 !      use MD, only: totT,t_bath
17993 #endif
17994 #endif
17995       double precision h_base
17996       external h_base
17997
17998 !c     Input arguments
17999       integer resi,resj,resk,m,itypi,itypj,itypk
18000
18001 !c     Output arguments
18002       double precision eij,eij1,eij2,eij3
18003
18004 !c     Local variables
18005       logical havebond
18006 !c      integer itypi,itypj,k,l
18007       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18008       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18009       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18010       double precision sig0ij,ljd,sig,fac,e1,e2
18011       double precision dcosom1(3),dcosom2(3),ed
18012       double precision pom1,pom2
18013       double precision ljA,ljB,ljXs
18014       double precision d_ljB(1:3)
18015       double precision ssA,ssB,ssC,ssXs
18016       double precision ssxm,ljxm,ssm,ljm
18017       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18018       eij=0.0
18019       if (dtriss.eq.0) return
18020       i=resi
18021       j=resj
18022       k=resk
18023 !C      write(iout,*) resi,resj,resk
18024       itypi=itype(i,1)
18025       dxi=dc_norm(1,nres+i)
18026       dyi=dc_norm(2,nres+i)
18027       dzi=dc_norm(3,nres+i)
18028       dsci_inv=vbld_inv(i+nres)
18029       xi=c(1,nres+i)
18030       yi=c(2,nres+i)
18031       zi=c(3,nres+i)
18032       itypj=itype(j,1)
18033       xj=c(1,nres+j)
18034       yj=c(2,nres+j)
18035       zj=c(3,nres+j)
18036
18037       dxj=dc_norm(1,nres+j)
18038       dyj=dc_norm(2,nres+j)
18039       dzj=dc_norm(3,nres+j)
18040       dscj_inv=vbld_inv(j+nres)
18041       itypk=itype(k,1)
18042       xk=c(1,nres+k)
18043       yk=c(2,nres+k)
18044       zk=c(3,nres+k)
18045
18046       dxk=dc_norm(1,nres+k)
18047       dyk=dc_norm(2,nres+k)
18048       dzk=dc_norm(3,nres+k)
18049       dscj_inv=vbld_inv(k+nres)
18050       xij=xj-xi
18051       xik=xk-xi
18052       xjk=xk-xj
18053       yij=yj-yi
18054       yik=yk-yi
18055       yjk=yk-yj
18056       zij=zj-zi
18057       zik=zk-zi
18058       zjk=zk-zj
18059       rrij=(xij*xij+yij*yij+zij*zij)
18060       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18061       rrik=(xik*xik+yik*yik+zik*zik)
18062       rik=dsqrt(rrik)
18063       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18064       rjk=dsqrt(rrjk)
18065 !C there are three combination of distances for each trisulfide bonds
18066 !C The first case the ith atom is the center
18067 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18068 !C distance y is second distance the a,b,c,d are parameters derived for
18069 !C this problem d parameter was set as a penalty currenlty set to 1.
18070       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18071       eij1=0.0d0
18072       else
18073       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18074       endif
18075 !C second case jth atom is center
18076       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18077       eij2=0.0d0
18078       else
18079       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18080       endif
18081 !C the third case kth atom is the center
18082       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18083       eij3=0.0d0
18084       else
18085       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18086       endif
18087 !C      eij2=0.0
18088 !C      eij3=0.0
18089 !C      eij1=0.0
18090       eij=eij1+eij2+eij3
18091 !C      write(iout,*)i,j,k,eij
18092 !C The energy penalty calculated now time for the gradient part
18093 !C derivative over rij
18094       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18095       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18096             gg(1)=xij*fac/rij
18097             gg(2)=yij*fac/rij
18098             gg(3)=zij*fac/rij
18099       do m=1,3
18100         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18101         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18102       enddo
18103
18104       do l=1,3
18105         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18106         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18107       enddo
18108 !C now derivative over rik
18109       fac=-eij1**2/dtriss* &
18110       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18111       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18112             gg(1)=xik*fac/rik
18113             gg(2)=yik*fac/rik
18114             gg(3)=zik*fac/rik
18115       do m=1,3
18116         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18117         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18118       enddo
18119       do l=1,3
18120         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18121         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18122       enddo
18123 !C now derivative over rjk
18124       fac=-eij2**2/dtriss* &
18125       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18126       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18127             gg(1)=xjk*fac/rjk
18128             gg(2)=yjk*fac/rjk
18129             gg(3)=zjk*fac/rjk
18130       do m=1,3
18131         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18132         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18133       enddo
18134       do l=1,3
18135         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18136         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18137       enddo
18138       return
18139       end subroutine triple_ssbond_ene
18140
18141
18142
18143 !-----------------------------------------------------------------------------
18144       real(kind=8) function h_base(x,deriv)
18145 !     A smooth function going 0->1 in range [0,1]
18146 !     It should NOT be called outside range [0,1], it will not work there.
18147       implicit none
18148
18149 !     Input arguments
18150       real(kind=8) :: x
18151
18152 !     Output arguments
18153       real(kind=8) :: deriv
18154
18155 !     Local variables
18156       real(kind=8) :: xsq
18157
18158
18159 !     Two parabolas put together.  First derivative zero at extrema
18160 !$$$      if (x.lt.0.5D0) then
18161 !$$$        h_base=2.0D0*x*x
18162 !$$$        deriv=4.0D0*x
18163 !$$$      else
18164 !$$$        deriv=1.0D0-x
18165 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18166 !$$$        deriv=4.0D0*deriv
18167 !$$$      endif
18168
18169 !     Third degree polynomial.  First derivative zero at extrema
18170       h_base=x*x*(3.0d0-2.0d0*x)
18171       deriv=6.0d0*x*(1.0d0-x)
18172
18173 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18174 !$$$      xsq=x*x
18175 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18176 !$$$      deriv=x-1.0d0
18177 !$$$      deriv=deriv*deriv
18178 !$$$      deriv=30.0d0*xsq*deriv
18179
18180       return
18181       end function h_base
18182 !-----------------------------------------------------------------------------
18183       subroutine dyn_set_nss
18184 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18185 !      implicit none
18186       use MD_data, only: totT,t_bath
18187 !     Includes
18188 !      include 'DIMENSIONS'
18189 #ifdef MPI
18190       include "mpif.h"
18191 #endif
18192 !      include 'COMMON.SBRIDGE'
18193 !      include 'COMMON.CHAIN'
18194 !      include 'COMMON.IOUNITS'
18195 !      include 'COMMON.SETUP'
18196 !      include 'COMMON.MD'
18197 !     Local variables
18198       real(kind=8) :: emin
18199       integer :: i,j,imin,ierr
18200       integer :: diff,allnss,newnss
18201       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18202                 newihpb,newjhpb
18203       logical :: found
18204       integer,dimension(0:nfgtasks) :: i_newnss
18205       integer,dimension(0:nfgtasks) :: displ
18206       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18207       integer :: g_newnss
18208
18209       allnss=0
18210       do i=1,nres-1
18211         do j=i+1,nres
18212           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18213             allnss=allnss+1
18214             allflag(allnss)=0
18215             allihpb(allnss)=i
18216             alljhpb(allnss)=j
18217           endif
18218         enddo
18219       enddo
18220
18221 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18222
18223  1    emin=1.0d300
18224       do i=1,allnss
18225         if (allflag(i).eq.0 .and. &
18226              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18227           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18228           imin=i
18229         endif
18230       enddo
18231       if (emin.lt.1.0d300) then
18232         allflag(imin)=1
18233         do i=1,allnss
18234           if (allflag(i).eq.0 .and. &
18235                (allihpb(i).eq.allihpb(imin) .or. &
18236                alljhpb(i).eq.allihpb(imin) .or. &
18237                allihpb(i).eq.alljhpb(imin) .or. &
18238                alljhpb(i).eq.alljhpb(imin))) then
18239             allflag(i)=-1
18240           endif
18241         enddo
18242         goto 1
18243       endif
18244
18245 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18246
18247       newnss=0
18248       do i=1,allnss
18249         if (allflag(i).eq.1) then
18250           newnss=newnss+1
18251           newihpb(newnss)=allihpb(i)
18252           newjhpb(newnss)=alljhpb(i)
18253         endif
18254       enddo
18255
18256 #ifdef MPI
18257       if (nfgtasks.gt.1)then
18258
18259         call MPI_Reduce(newnss,g_newnss,1,&
18260           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18261         call MPI_Gather(newnss,1,MPI_INTEGER,&
18262                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18263         displ(0)=0
18264         do i=1,nfgtasks-1,1
18265           displ(i)=i_newnss(i-1)+displ(i-1)
18266         enddo
18267         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18268                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18269                          king,FG_COMM,IERR)
18270         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18271                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18272                          king,FG_COMM,IERR)
18273         if(fg_rank.eq.0) then
18274 !         print *,'g_newnss',g_newnss
18275 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18276 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18277          newnss=g_newnss
18278          do i=1,newnss
18279           newihpb(i)=g_newihpb(i)
18280           newjhpb(i)=g_newjhpb(i)
18281          enddo
18282         endif
18283       endif
18284 #endif
18285
18286       diff=newnss-nss
18287
18288 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18289 !       print *,newnss,nss,maxdim
18290       do i=1,nss
18291         found=.false.
18292 !        print *,newnss
18293         do j=1,newnss
18294 !!          print *,j
18295           if (idssb(i).eq.newihpb(j) .and. &
18296                jdssb(i).eq.newjhpb(j)) found=.true.
18297         enddo
18298 #ifndef CLUST
18299 #ifndef WHAM
18300 !        write(iout,*) "found",found,i,j
18301         if (.not.found.and.fg_rank.eq.0) &
18302             write(iout,'(a15,f12.2,f8.1,2i5)') &
18303              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18304 #endif
18305 #endif
18306       enddo
18307
18308       do i=1,newnss
18309         found=.false.
18310         do j=1,nss
18311 !          print *,i,j
18312           if (newihpb(i).eq.idssb(j) .and. &
18313                newjhpb(i).eq.jdssb(j)) found=.true.
18314         enddo
18315 #ifndef CLUST
18316 #ifndef WHAM
18317 !        write(iout,*) "found",found,i,j
18318         if (.not.found.and.fg_rank.eq.0) &
18319             write(iout,'(a15,f12.2,f8.1,2i5)') &
18320              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18321 #endif
18322 #endif
18323       enddo
18324
18325       nss=newnss
18326       do i=1,nss
18327         idssb(i)=newihpb(i)
18328         jdssb(i)=newjhpb(i)
18329       enddo
18330
18331       return
18332       end subroutine dyn_set_nss
18333 ! Lipid transfer energy function
18334       subroutine Eliptransfer(eliptran)
18335 !C this is done by Adasko
18336 !C      print *,"wchodze"
18337 !C structure of box:
18338 !C      water
18339 !C--bordliptop-- buffore starts
18340 !C--bufliptop--- here true lipid starts
18341 !C      lipid
18342 !C--buflipbot--- lipid ends buffore starts
18343 !C--bordlipbot--buffore ends
18344       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18345       integer :: i
18346       eliptran=0.0
18347 !      print *, "I am in eliptran"
18348       do i=ilip_start,ilip_end
18349 !C       do i=1,1
18350         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18351          cycle
18352
18353         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18354         if (positi.le.0.0) positi=positi+boxzsize
18355 !C        print *,i
18356 !C first for peptide groups
18357 !c for each residue check if it is in lipid or lipid water border area
18358        if ((positi.gt.bordlipbot)  &
18359       .and.(positi.lt.bordliptop)) then
18360 !C the energy transfer exist
18361         if (positi.lt.buflipbot) then
18362 !C what fraction I am in
18363          fracinbuf=1.0d0-      &
18364              ((positi-bordlipbot)/lipbufthick)
18365 !C lipbufthick is thickenes of lipid buffore
18366          sslip=sscalelip(fracinbuf)
18367          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18368          eliptran=eliptran+sslip*pepliptran
18369          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18370          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18371 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18372
18373 !C        print *,"doing sccale for lower part"
18374 !C         print *,i,sslip,fracinbuf,ssgradlip
18375         elseif (positi.gt.bufliptop) then
18376          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18377          sslip=sscalelip(fracinbuf)
18378          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18379          eliptran=eliptran+sslip*pepliptran
18380          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18381          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18382 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18383 !C          print *, "doing sscalefor top part"
18384 !C         print *,i,sslip,fracinbuf,ssgradlip
18385         else
18386          eliptran=eliptran+pepliptran
18387 !C         print *,"I am in true lipid"
18388         endif
18389 !C       else
18390 !C       eliptran=elpitran+0.0 ! I am in water
18391        endif
18392        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18393        enddo
18394 ! here starts the side chain transfer
18395        do i=ilip_start,ilip_end
18396         if (itype(i,1).eq.ntyp1) cycle
18397         positi=(mod(c(3,i+nres),boxzsize))
18398         if (positi.le.0) positi=positi+boxzsize
18399 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18400 !c for each residue check if it is in lipid or lipid water border area
18401 !C       respos=mod(c(3,i+nres),boxzsize)
18402 !C       print *,positi,bordlipbot,buflipbot
18403        if ((positi.gt.bordlipbot) &
18404        .and.(positi.lt.bordliptop)) then
18405 !C the energy transfer exist
18406         if (positi.lt.buflipbot) then
18407          fracinbuf=1.0d0-   &
18408            ((positi-bordlipbot)/lipbufthick)
18409 !C lipbufthick is thickenes of lipid buffore
18410          sslip=sscalelip(fracinbuf)
18411          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18412          eliptran=eliptran+sslip*liptranene(itype(i,1))
18413          gliptranx(3,i)=gliptranx(3,i) &
18414       +ssgradlip*liptranene(itype(i,1))
18415          gliptranc(3,i-1)= gliptranc(3,i-1) &
18416       +ssgradlip*liptranene(itype(i,1))
18417 !C         print *,"doing sccale for lower part"
18418         elseif (positi.gt.bufliptop) then
18419          fracinbuf=1.0d0-  &
18420       ((bordliptop-positi)/lipbufthick)
18421          sslip=sscalelip(fracinbuf)
18422          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18423          eliptran=eliptran+sslip*liptranene(itype(i,1))
18424          gliptranx(3,i)=gliptranx(3,i)  &
18425        +ssgradlip*liptranene(itype(i,1))
18426          gliptranc(3,i-1)= gliptranc(3,i-1) &
18427       +ssgradlip*liptranene(itype(i,1))
18428 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18429         else
18430          eliptran=eliptran+liptranene(itype(i,1))
18431 !C         print *,"I am in true lipid"
18432         endif
18433         endif ! if in lipid or buffor
18434 !C       else
18435 !C       eliptran=elpitran+0.0 ! I am in water
18436         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18437        enddo
18438        return
18439        end  subroutine Eliptransfer
18440 !----------------------------------NANO FUNCTIONS
18441 !C-----------------------------------------------------------------------
18442 !C-----------------------------------------------------------
18443 !C This subroutine is to mimic the histone like structure but as well can be
18444 !C utilizet to nanostructures (infinit) small modification has to be used to
18445 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18446 !C gradient has to be modified at the ends
18447 !C The energy function is Kihara potential
18448 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18449 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18450 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18451 !C simple Kihara potential
18452       subroutine calctube(Etube)
18453       real(kind=8),dimension(3) :: vectube
18454       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18455        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18456        sc_aa_tube,sc_bb_tube
18457       integer :: i,j,iti
18458       Etube=0.0d0
18459       do i=itube_start,itube_end
18460         enetube(i)=0.0d0
18461         enetube(i+nres)=0.0d0
18462       enddo
18463 !C first we calculate the distance from tube center
18464 !C for UNRES
18465        do i=itube_start,itube_end
18466 !C lets ommit dummy atoms for now
18467        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18468 !C now calculate distance from center of tube and direction vectors
18469       xmin=boxxsize
18470       ymin=boxysize
18471 ! Find minimum distance in periodic box
18472         do j=-1,1
18473          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18474          vectube(1)=vectube(1)+boxxsize*j
18475          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18476          vectube(2)=vectube(2)+boxysize*j
18477          xminact=abs(vectube(1)-tubecenter(1))
18478          yminact=abs(vectube(2)-tubecenter(2))
18479            if (xmin.gt.xminact) then
18480             xmin=xminact
18481             xtemp=vectube(1)
18482            endif
18483            if (ymin.gt.yminact) then
18484              ymin=yminact
18485              ytemp=vectube(2)
18486             endif
18487          enddo
18488       vectube(1)=xtemp
18489       vectube(2)=ytemp
18490       vectube(1)=vectube(1)-tubecenter(1)
18491       vectube(2)=vectube(2)-tubecenter(2)
18492
18493 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18494 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18495
18496 !C as the tube is infinity we do not calculate the Z-vector use of Z
18497 !C as chosen axis
18498       vectube(3)=0.0d0
18499 !C now calculte the distance
18500        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18501 !C now normalize vector
18502       vectube(1)=vectube(1)/tub_r
18503       vectube(2)=vectube(2)/tub_r
18504 !C calculte rdiffrence between r and r0
18505       rdiff=tub_r-tubeR0
18506 !C and its 6 power
18507       rdiff6=rdiff**6.0d0
18508 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18509        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18510 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18511 !C       print *,rdiff,rdiff6,pep_aa_tube
18512 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18513 !C now we calculate gradient
18514        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18515             6.0d0*pep_bb_tube)/rdiff6/rdiff
18516 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18517 !C     &rdiff,fac
18518 !C now direction of gg_tube vector
18519         do j=1,3
18520         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18521         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18522         enddo
18523         enddo
18524 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18525 !C        print *,gg_tube(1,0),"TU"
18526
18527
18528        do i=itube_start,itube_end
18529 !C Lets not jump over memory as we use many times iti
18530          iti=itype(i,1)
18531 !C lets ommit dummy atoms for now
18532          if ((iti.eq.ntyp1)  &
18533 !C in UNRES uncomment the line below as GLY has no side-chain...
18534 !C      .or.(iti.eq.10)
18535         ) cycle
18536       xmin=boxxsize
18537       ymin=boxysize
18538         do j=-1,1
18539          vectube(1)=mod((c(1,i+nres)),boxxsize)
18540          vectube(1)=vectube(1)+boxxsize*j
18541          vectube(2)=mod((c(2,i+nres)),boxysize)
18542          vectube(2)=vectube(2)+boxysize*j
18543
18544          xminact=abs(vectube(1)-tubecenter(1))
18545          yminact=abs(vectube(2)-tubecenter(2))
18546            if (xmin.gt.xminact) then
18547             xmin=xminact
18548             xtemp=vectube(1)
18549            endif
18550            if (ymin.gt.yminact) then
18551              ymin=yminact
18552              ytemp=vectube(2)
18553             endif
18554          enddo
18555       vectube(1)=xtemp
18556       vectube(2)=ytemp
18557 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18558 !C     &     tubecenter(2)
18559       vectube(1)=vectube(1)-tubecenter(1)
18560       vectube(2)=vectube(2)-tubecenter(2)
18561
18562 !C as the tube is infinity we do not calculate the Z-vector use of Z
18563 !C as chosen axis
18564       vectube(3)=0.0d0
18565 !C now calculte the distance
18566        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18567 !C now normalize vector
18568       vectube(1)=vectube(1)/tub_r
18569       vectube(2)=vectube(2)/tub_r
18570
18571 !C calculte rdiffrence between r and r0
18572       rdiff=tub_r-tubeR0
18573 !C and its 6 power
18574       rdiff6=rdiff**6.0d0
18575 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18576        sc_aa_tube=sc_aa_tube_par(iti)
18577        sc_bb_tube=sc_bb_tube_par(iti)
18578        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18579        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18580              6.0d0*sc_bb_tube/rdiff6/rdiff
18581 !C now direction of gg_tube vector
18582          do j=1,3
18583           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18584           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18585          enddo
18586         enddo
18587         do i=itube_start,itube_end
18588           Etube=Etube+enetube(i)+enetube(i+nres)
18589         enddo
18590 !C        print *,"ETUBE", etube
18591         return
18592         end subroutine calctube
18593 !C TO DO 1) add to total energy
18594 !C       2) add to gradient summation
18595 !C       3) add reading parameters (AND of course oppening of PARAM file)
18596 !C       4) add reading the center of tube
18597 !C       5) add COMMONs
18598 !C       6) add to zerograd
18599 !C       7) allocate matrices
18600
18601
18602 !C-----------------------------------------------------------------------
18603 !C-----------------------------------------------------------
18604 !C This subroutine is to mimic the histone like structure but as well can be
18605 !C utilizet to nanostructures (infinit) small modification has to be used to
18606 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18607 !C gradient has to be modified at the ends
18608 !C The energy function is Kihara potential
18609 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18610 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18611 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18612 !C simple Kihara potential
18613       subroutine calctube2(Etube)
18614             real(kind=8),dimension(3) :: vectube
18615       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18616        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18617        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18618       integer:: i,j,iti
18619       Etube=0.0d0
18620       do i=itube_start,itube_end
18621         enetube(i)=0.0d0
18622         enetube(i+nres)=0.0d0
18623       enddo
18624 !C first we calculate the distance from tube center
18625 !C first sugare-phosphate group for NARES this would be peptide group
18626 !C for UNRES
18627        do i=itube_start,itube_end
18628 !C lets ommit dummy atoms for now
18629
18630        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18631 !C now calculate distance from center of tube and direction vectors
18632 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18633 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18634 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18635 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18636       xmin=boxxsize
18637       ymin=boxysize
18638         do j=-1,1
18639          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18640          vectube(1)=vectube(1)+boxxsize*j
18641          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18642          vectube(2)=vectube(2)+boxysize*j
18643
18644          xminact=abs(vectube(1)-tubecenter(1))
18645          yminact=abs(vectube(2)-tubecenter(2))
18646            if (xmin.gt.xminact) then
18647             xmin=xminact
18648             xtemp=vectube(1)
18649            endif
18650            if (ymin.gt.yminact) then
18651              ymin=yminact
18652              ytemp=vectube(2)
18653             endif
18654          enddo
18655       vectube(1)=xtemp
18656       vectube(2)=ytemp
18657       vectube(1)=vectube(1)-tubecenter(1)
18658       vectube(2)=vectube(2)-tubecenter(2)
18659
18660 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18661 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18662
18663 !C as the tube is infinity we do not calculate the Z-vector use of Z
18664 !C as chosen axis
18665       vectube(3)=0.0d0
18666 !C now calculte the distance
18667        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18668 !C now normalize vector
18669       vectube(1)=vectube(1)/tub_r
18670       vectube(2)=vectube(2)/tub_r
18671 !C calculte rdiffrence between r and r0
18672       rdiff=tub_r-tubeR0
18673 !C and its 6 power
18674       rdiff6=rdiff**6.0d0
18675 !C THIS FRAGMENT MAKES TUBE FINITE
18676         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18677         if (positi.le.0) positi=positi+boxzsize
18678 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18679 !c for each residue check if it is in lipid or lipid water border area
18680 !C       respos=mod(c(3,i+nres),boxzsize)
18681 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18682        if ((positi.gt.bordtubebot)  &
18683         .and.(positi.lt.bordtubetop)) then
18684 !C the energy transfer exist
18685         if (positi.lt.buftubebot) then
18686          fracinbuf=1.0d0-  &
18687            ((positi-bordtubebot)/tubebufthick)
18688 !C lipbufthick is thickenes of lipid buffore
18689          sstube=sscalelip(fracinbuf)
18690          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18691 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18692          enetube(i)=enetube(i)+sstube*tubetranenepep
18693 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18694 !C     &+ssgradtube*tubetranene(itype(i,1))
18695 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18696 !C     &+ssgradtube*tubetranene(itype(i,1))
18697 !C         print *,"doing sccale for lower part"
18698         elseif (positi.gt.buftubetop) then
18699          fracinbuf=1.0d0-  &
18700         ((bordtubetop-positi)/tubebufthick)
18701          sstube=sscalelip(fracinbuf)
18702          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18703          enetube(i)=enetube(i)+sstube*tubetranenepep
18704 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18705 !C     &+ssgradtube*tubetranene(itype(i,1))
18706 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18707 !C     &+ssgradtube*tubetranene(itype(i,1))
18708 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18709         else
18710          sstube=1.0d0
18711          ssgradtube=0.0d0
18712          enetube(i)=enetube(i)+sstube*tubetranenepep
18713 !C         print *,"I am in true lipid"
18714         endif
18715         else
18716 !C          sstube=0.0d0
18717 !C          ssgradtube=0.0d0
18718         cycle
18719         endif ! if in lipid or buffor
18720
18721 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18722        enetube(i)=enetube(i)+sstube* &
18723         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18724 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18725 !C       print *,rdiff,rdiff6,pep_aa_tube
18726 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18727 !C now we calculate gradient
18728        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18729              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18730 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18731 !C     &rdiff,fac
18732
18733 !C now direction of gg_tube vector
18734        do j=1,3
18735         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18736         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18737         enddo
18738          gg_tube(3,i)=gg_tube(3,i)  &
18739        +ssgradtube*enetube(i)/sstube/2.0d0
18740          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18741        +ssgradtube*enetube(i)/sstube/2.0d0
18742
18743         enddo
18744 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18745 !C        print *,gg_tube(1,0),"TU"
18746         do i=itube_start,itube_end
18747 !C Lets not jump over memory as we use many times iti
18748          iti=itype(i,1)
18749 !C lets ommit dummy atoms for now
18750          if ((iti.eq.ntyp1) &
18751 !!C in UNRES uncomment the line below as GLY has no side-chain...
18752            .or.(iti.eq.10) &
18753           ) cycle
18754           vectube(1)=c(1,i+nres)
18755           vectube(1)=mod(vectube(1),boxxsize)
18756           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18757           vectube(2)=c(2,i+nres)
18758           vectube(2)=mod(vectube(2),boxysize)
18759           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18760
18761       vectube(1)=vectube(1)-tubecenter(1)
18762       vectube(2)=vectube(2)-tubecenter(2)
18763 !C THIS FRAGMENT MAKES TUBE FINITE
18764         positi=(mod(c(3,i+nres),boxzsize))
18765         if (positi.le.0) positi=positi+boxzsize
18766 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18767 !c for each residue check if it is in lipid or lipid water border area
18768 !C       respos=mod(c(3,i+nres),boxzsize)
18769 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18770
18771        if ((positi.gt.bordtubebot)  &
18772         .and.(positi.lt.bordtubetop)) then
18773 !C the energy transfer exist
18774         if (positi.lt.buftubebot) then
18775          fracinbuf=1.0d0- &
18776             ((positi-bordtubebot)/tubebufthick)
18777 !C lipbufthick is thickenes of lipid buffore
18778          sstube=sscalelip(fracinbuf)
18779          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18780 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18781          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18782 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18783 !C     &+ssgradtube*tubetranene(itype(i,1))
18784 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18785 !C     &+ssgradtube*tubetranene(itype(i,1))
18786 !C         print *,"doing sccale for lower part"
18787         elseif (positi.gt.buftubetop) then
18788          fracinbuf=1.0d0- &
18789         ((bordtubetop-positi)/tubebufthick)
18790
18791          sstube=sscalelip(fracinbuf)
18792          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18793          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18794 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18795 !C     &+ssgradtube*tubetranene(itype(i,1))
18796 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18797 !C     &+ssgradtube*tubetranene(itype(i,1))
18798 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18799         else
18800          sstube=1.0d0
18801          ssgradtube=0.0d0
18802          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18803 !C         print *,"I am in true lipid"
18804         endif
18805         else
18806 !C          sstube=0.0d0
18807 !C          ssgradtube=0.0d0
18808         cycle
18809         endif ! if in lipid or buffor
18810 !CEND OF FINITE FRAGMENT
18811 !C as the tube is infinity we do not calculate the Z-vector use of Z
18812 !C as chosen axis
18813       vectube(3)=0.0d0
18814 !C now calculte the distance
18815        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18816 !C now normalize vector
18817       vectube(1)=vectube(1)/tub_r
18818       vectube(2)=vectube(2)/tub_r
18819 !C calculte rdiffrence between r and r0
18820       rdiff=tub_r-tubeR0
18821 !C and its 6 power
18822       rdiff6=rdiff**6.0d0
18823 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18824        sc_aa_tube=sc_aa_tube_par(iti)
18825        sc_bb_tube=sc_bb_tube_par(iti)
18826        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
18827                        *sstube+enetube(i+nres)
18828 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18829 !C now we calculate gradient
18830        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
18831             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
18832 !C now direction of gg_tube vector
18833          do j=1,3
18834           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18835           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18836          enddo
18837          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
18838        +ssgradtube*enetube(i+nres)/sstube
18839          gg_tube(3,i-1)= gg_tube(3,i-1) &
18840        +ssgradtube*enetube(i+nres)/sstube
18841
18842         enddo
18843         do i=itube_start,itube_end
18844           Etube=Etube+enetube(i)+enetube(i+nres)
18845         enddo
18846 !C        print *,"ETUBE", etube
18847         return
18848         end subroutine calctube2
18849 !=====================================================================================================================================
18850       subroutine calcnano(Etube)
18851       real(kind=8),dimension(3) :: vectube
18852
18853       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18854        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
18855        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
18856        integer:: i,j,iti,r
18857
18858       Etube=0.0d0
18859 !      print *,itube_start,itube_end,"poczatek"
18860       do i=itube_start,itube_end
18861         enetube(i)=0.0d0
18862         enetube(i+nres)=0.0d0
18863       enddo
18864 !C first we calculate the distance from tube center
18865 !C first sugare-phosphate group for NARES this would be peptide group
18866 !C for UNRES
18867        do i=itube_start,itube_end
18868 !C lets ommit dummy atoms for now
18869        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18870 !C now calculate distance from center of tube and direction vectors
18871       xmin=boxxsize
18872       ymin=boxysize
18873       zmin=boxzsize
18874
18875         do j=-1,1
18876          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18877          vectube(1)=vectube(1)+boxxsize*j
18878          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18879          vectube(2)=vectube(2)+boxysize*j
18880          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18881          vectube(3)=vectube(3)+boxzsize*j
18882
18883
18884          xminact=dabs(vectube(1)-tubecenter(1))
18885          yminact=dabs(vectube(2)-tubecenter(2))
18886          zminact=dabs(vectube(3)-tubecenter(3))
18887
18888            if (xmin.gt.xminact) then
18889             xmin=xminact
18890             xtemp=vectube(1)
18891            endif
18892            if (ymin.gt.yminact) then
18893              ymin=yminact
18894              ytemp=vectube(2)
18895             endif
18896            if (zmin.gt.zminact) then
18897              zmin=zminact
18898              ztemp=vectube(3)
18899             endif
18900          enddo
18901       vectube(1)=xtemp
18902       vectube(2)=ytemp
18903       vectube(3)=ztemp
18904
18905       vectube(1)=vectube(1)-tubecenter(1)
18906       vectube(2)=vectube(2)-tubecenter(2)
18907       vectube(3)=vectube(3)-tubecenter(3)
18908
18909 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18910 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18911 !C as the tube is infinity we do not calculate the Z-vector use of Z
18912 !C as chosen axis
18913 !C      vectube(3)=0.0d0
18914 !C now calculte the distance
18915        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18916 !C now normalize vector
18917       vectube(1)=vectube(1)/tub_r
18918       vectube(2)=vectube(2)/tub_r
18919       vectube(3)=vectube(3)/tub_r
18920 !C calculte rdiffrence between r and r0
18921       rdiff=tub_r-tubeR0
18922 !C and its 6 power
18923       rdiff6=rdiff**6.0d0
18924 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18925        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18926 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18927 !C       print *,rdiff,rdiff6,pep_aa_tube
18928 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18929 !C now we calculate gradient
18930        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
18931             6.0d0*pep_bb_tube)/rdiff6/rdiff
18932 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18933 !C     &rdiff,fac
18934          if (acavtubpep.eq.0.0d0) then
18935 !C go to 667
18936          enecavtube(i)=0.0
18937          faccav=0.0
18938          else
18939          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
18940          enecavtube(i)=  &
18941         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
18942         /denominator
18943          enecavtube(i)=0.0
18944          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
18945         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
18946         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
18947         /denominator**2.0d0
18948 !C         faccav=0.0
18949 !C         fac=fac+faccav
18950 !C 667     continue
18951          endif
18952           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
18953         do j=1,3
18954         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18955         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18956         enddo
18957         enddo
18958
18959        do i=itube_start,itube_end
18960         enecavtube(i)=0.0d0
18961 !C Lets not jump over memory as we use many times iti
18962          iti=itype(i,1)
18963 !C lets ommit dummy atoms for now
18964          if ((iti.eq.ntyp1) &
18965 !C in UNRES uncomment the line below as GLY has no side-chain...
18966 !C      .or.(iti.eq.10)
18967          ) cycle
18968       xmin=boxxsize
18969       ymin=boxysize
18970       zmin=boxzsize
18971         do j=-1,1
18972          vectube(1)=dmod((c(1,i+nres)),boxxsize)
18973          vectube(1)=vectube(1)+boxxsize*j
18974          vectube(2)=dmod((c(2,i+nres)),boxysize)
18975          vectube(2)=vectube(2)+boxysize*j
18976          vectube(3)=dmod((c(3,i+nres)),boxzsize)
18977          vectube(3)=vectube(3)+boxzsize*j
18978
18979
18980          xminact=dabs(vectube(1)-tubecenter(1))
18981          yminact=dabs(vectube(2)-tubecenter(2))
18982          zminact=dabs(vectube(3)-tubecenter(3))
18983
18984            if (xmin.gt.xminact) then
18985             xmin=xminact
18986             xtemp=vectube(1)
18987            endif
18988            if (ymin.gt.yminact) then
18989              ymin=yminact
18990              ytemp=vectube(2)
18991             endif
18992            if (zmin.gt.zminact) then
18993              zmin=zminact
18994              ztemp=vectube(3)
18995             endif
18996          enddo
18997       vectube(1)=xtemp
18998       vectube(2)=ytemp
18999       vectube(3)=ztemp
19000
19001 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19002 !C     &     tubecenter(2)
19003       vectube(1)=vectube(1)-tubecenter(1)
19004       vectube(2)=vectube(2)-tubecenter(2)
19005       vectube(3)=vectube(3)-tubecenter(3)
19006 !C now calculte the distance
19007        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19008 !C now normalize vector
19009       vectube(1)=vectube(1)/tub_r
19010       vectube(2)=vectube(2)/tub_r
19011       vectube(3)=vectube(3)/tub_r
19012
19013 !C calculte rdiffrence between r and r0
19014       rdiff=tub_r-tubeR0
19015 !C and its 6 power
19016       rdiff6=rdiff**6.0d0
19017        sc_aa_tube=sc_aa_tube_par(iti)
19018        sc_bb_tube=sc_bb_tube_par(iti)
19019        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19020 !C       enetube(i+nres)=0.0d0
19021 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19022 !C now we calculate gradient
19023        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19024             6.0d0*sc_bb_tube/rdiff6/rdiff
19025 !C       fac=0.0
19026 !C now direction of gg_tube vector
19027 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19028          if (acavtub(iti).eq.0.0d0) then
19029 !C go to 667
19030          enecavtube(i+nres)=0.0d0
19031          faccav=0.0d0
19032          else
19033          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19034          enecavtube(i+nres)=   &
19035         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19036         /denominator
19037 !C         enecavtube(i)=0.0
19038          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19039         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19040         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19041         /denominator**2.0d0
19042 !C         faccav=0.0
19043          fac=fac+faccav
19044 !C 667     continue
19045          endif
19046 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19047 !C     &   enecavtube(i),faccav
19048 !C         print *,"licz=",
19049 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19050 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19051          do j=1,3
19052           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19053           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19054          enddo
19055           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19056         enddo
19057
19058
19059
19060         do i=itube_start,itube_end
19061           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19062          +enecavtube(i+nres)
19063         enddo
19064 !        do i=1,20
19065 !         print *,"begin", i,"a"
19066 !         do r=1,10000
19067 !          rdiff=r/100.0d0
19068 !          rdiff6=rdiff**6.0d0
19069 !          sc_aa_tube=sc_aa_tube_par(i)
19070 !          sc_bb_tube=sc_bb_tube_par(i)
19071 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19072 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19073 !          enecavtube(i)=   &
19074 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19075 !         /denominator
19076
19077 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19078 !         enddo
19079 !         print *,"end",i,"a"
19080 !        enddo
19081 !C        print *,"ETUBE", etube
19082         return
19083         end subroutine calcnano
19084
19085 !===============================================
19086 !--------------------------------------------------------------------------------
19087 !C first for shielding is setting of function of side-chains
19088
19089        subroutine set_shield_fac2
19090        real(kind=8) :: div77_81=0.974996043d0, &
19091         div4_81=0.2222222222d0
19092        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19093          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19094          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19095          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19096 !C the vector between center of side_chain and peptide group
19097        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19098          pept_group,costhet_grad,cosphi_grad_long, &
19099          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19100          sh_frac_dist_grad,pep_side
19101         integer i,j,k
19102 !C      write(2,*) "ivec",ivec_start,ivec_end
19103       do i=1,nres
19104         fac_shield(i)=0.0d0
19105         do j=1,3
19106         grad_shield(j,i)=0.0d0
19107         enddo
19108       enddo
19109       do i=ivec_start,ivec_end
19110 !C      do i=1,nres-1
19111 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19112       ishield_list(i)=0
19113       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19114 !Cif there two consequtive dummy atoms there is no peptide group between them
19115 !C the line below has to be changed for FGPROC>1
19116       VolumeTotal=0.0
19117       do k=1,nres
19118        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19119        dist_pep_side=0.0
19120        dist_side_calf=0.0
19121        do j=1,3
19122 !C first lets set vector conecting the ithe side-chain with kth side-chain
19123       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19124 !C      pep_side(j)=2.0d0
19125 !C and vector conecting the side-chain with its proper calfa
19126       side_calf(j)=c(j,k+nres)-c(j,k)
19127 !C      side_calf(j)=2.0d0
19128       pept_group(j)=c(j,i)-c(j,i+1)
19129 !C lets have their lenght
19130       dist_pep_side=pep_side(j)**2+dist_pep_side
19131       dist_side_calf=dist_side_calf+side_calf(j)**2
19132       dist_pept_group=dist_pept_group+pept_group(j)**2
19133       enddo
19134        dist_pep_side=sqrt(dist_pep_side)
19135        dist_pept_group=sqrt(dist_pept_group)
19136        dist_side_calf=sqrt(dist_side_calf)
19137       do j=1,3
19138         pep_side_norm(j)=pep_side(j)/dist_pep_side
19139         side_calf_norm(j)=dist_side_calf
19140       enddo
19141 !C now sscale fraction
19142        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19143 !C       print *,buff_shield,"buff"
19144 !C now sscale
19145         if (sh_frac_dist.le.0.0) cycle
19146 !C        print *,ishield_list(i),i
19147 !C If we reach here it means that this side chain reaches the shielding sphere
19148 !C Lets add him to the list for gradient
19149         ishield_list(i)=ishield_list(i)+1
19150 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19151 !C this list is essential otherwise problem would be O3
19152         shield_list(ishield_list(i),i)=k
19153 !C Lets have the sscale value
19154         if (sh_frac_dist.gt.1.0) then
19155          scale_fac_dist=1.0d0
19156          do j=1,3
19157          sh_frac_dist_grad(j)=0.0d0
19158          enddo
19159         else
19160          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19161                         *(2.0d0*sh_frac_dist-3.0d0)
19162          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19163                        /dist_pep_side/buff_shield*0.5d0
19164          do j=1,3
19165          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19166 !C         sh_frac_dist_grad(j)=0.0d0
19167 !C         scale_fac_dist=1.0d0
19168 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19169 !C     &                    sh_frac_dist_grad(j)
19170          enddo
19171         endif
19172 !C this is what is now we have the distance scaling now volume...
19173       short=short_r_sidechain(itype(k,1))
19174       long=long_r_sidechain(itype(k,1))
19175       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19176       sinthet=short/dist_pep_side*costhet
19177 !C now costhet_grad
19178 !C       costhet=0.6d0
19179 !C       sinthet=0.8
19180        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19181 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19182 !C     &             -short/dist_pep_side**2/costhet)
19183 !C       costhet_fac=0.0d0
19184        do j=1,3
19185          costhet_grad(j)=costhet_fac*pep_side(j)
19186        enddo
19187 !C remember for the final gradient multiply costhet_grad(j)
19188 !C for side_chain by factor -2 !
19189 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19190 !C pep_side0pept_group is vector multiplication
19191       pep_side0pept_group=0.0d0
19192       do j=1,3
19193       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19194       enddo
19195       cosalfa=(pep_side0pept_group/ &
19196       (dist_pep_side*dist_side_calf))
19197       fac_alfa_sin=1.0d0-cosalfa**2
19198       fac_alfa_sin=dsqrt(fac_alfa_sin)
19199       rkprim=fac_alfa_sin*(long-short)+short
19200 !C      rkprim=short
19201
19202 !C now costhet_grad
19203        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19204 !C       cosphi=0.6
19205        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19206        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19207            dist_pep_side**2)
19208 !C       sinphi=0.8
19209        do j=1,3
19210          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19211       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19212       *(long-short)/fac_alfa_sin*cosalfa/ &
19213       ((dist_pep_side*dist_side_calf))* &
19214       ((side_calf(j))-cosalfa* &
19215       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19216 !C       cosphi_grad_long(j)=0.0d0
19217         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19218       *(long-short)/fac_alfa_sin*cosalfa &
19219       /((dist_pep_side*dist_side_calf))* &
19220       (pep_side(j)- &
19221       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19222 !C       cosphi_grad_loc(j)=0.0d0
19223        enddo
19224 !C      print *,sinphi,sinthet
19225       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19226      &                    /VSolvSphere_div
19227 !C     &                    *wshield
19228 !C now the gradient...
19229       do j=1,3
19230       grad_shield(j,i)=grad_shield(j,i) &
19231 !C gradient po skalowaniu
19232                      +(sh_frac_dist_grad(j)*VofOverlap &
19233 !C  gradient po costhet
19234             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19235         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19236             sinphi/sinthet*costhet*costhet_grad(j) &
19237            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19238         )*wshield
19239 !C grad_shield_side is Cbeta sidechain gradient
19240       grad_shield_side(j,ishield_list(i),i)=&
19241              (sh_frac_dist_grad(j)*-2.0d0&
19242              *VofOverlap&
19243             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19244        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19245             sinphi/sinthet*costhet*costhet_grad(j)&
19246            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19247             )*wshield
19248
19249        grad_shield_loc(j,ishield_list(i),i)=   &
19250             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19251       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19252             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19253              ))&
19254              *wshield
19255       enddo
19256       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19257       enddo
19258       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19259
19260 !C      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19261       enddo
19262       return
19263       end subroutine set_shield_fac2
19264 !----------------------------------------------------------------------------
19265 ! SOUBROUTINE FOR AFM
19266        subroutine AFMvel(Eafmforce)
19267        use MD_data, only:totTafm
19268       real(kind=8),dimension(3) :: diffafm
19269       real(kind=8) :: afmdist,Eafmforce
19270        integer :: i
19271 !C Only for check grad COMMENT if not used for checkgrad
19272 !C      totT=3.0d0
19273 !C--------------------------------------------------------
19274 !C      print *,"wchodze"
19275       afmdist=0.0d0
19276       Eafmforce=0.0d0
19277       do i=1,3
19278       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19279       afmdist=afmdist+diffafm(i)**2
19280       enddo
19281       afmdist=dsqrt(afmdist)
19282 !      totTafm=3.0
19283       Eafmforce=0.5d0*forceAFMconst &
19284       *(distafminit+totTafm*velAFMconst-afmdist)**2
19285 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19286       do i=1,3
19287       gradafm(i,afmend-1)=-forceAFMconst* &
19288        (distafminit+totTafm*velAFMconst-afmdist) &
19289        *diffafm(i)/afmdist
19290       gradafm(i,afmbeg-1)=forceAFMconst* &
19291       (distafminit+totTafm*velAFMconst-afmdist) &
19292       *diffafm(i)/afmdist
19293       enddo
19294 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19295       return
19296       end subroutine AFMvel
19297 !---------------------------------------------------------
19298        subroutine AFMforce(Eafmforce)
19299
19300       real(kind=8),dimension(3) :: diffafm
19301 !      real(kind=8) ::afmdist
19302       real(kind=8) :: afmdist,Eafmforce
19303       integer :: i
19304       afmdist=0.0d0
19305       Eafmforce=0.0d0
19306       do i=1,3
19307       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19308       afmdist=afmdist+diffafm(i)**2
19309       enddo
19310       afmdist=dsqrt(afmdist)
19311 !      print *,afmdist,distafminit
19312       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19313       do i=1,3
19314       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19315       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19316       enddo
19317 !C      print *,'AFM',Eafmforce
19318       return
19319       end subroutine AFMforce
19320
19321 !-----------------------------------------------------------------------------
19322 #ifdef WHAM
19323       subroutine read_ssHist
19324 !      implicit none
19325 !      Includes
19326 !      include 'DIMENSIONS'
19327 !      include "DIMENSIONS.FREE"
19328 !      include 'COMMON.FREE'
19329 !     Local variables
19330       integer :: i,j
19331       character(len=80) :: controlcard
19332
19333       do i=1,dyn_nssHist
19334         call card_concat(controlcard,.true.)
19335         read(controlcard,*) &
19336              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19337       enddo
19338
19339       return
19340       end subroutine read_ssHist
19341 #endif
19342 !-----------------------------------------------------------------------------
19343       integer function indmat(i,j)
19344 !el
19345 ! get the position of the jth ijth fragment of the chain coordinate system
19346 ! in the fromto array.
19347         integer :: i,j
19348
19349         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19350       return
19351       end function indmat
19352 !-----------------------------------------------------------------------------
19353       real(kind=8) function sigm(x)
19354 !el
19355        real(kind=8) :: x
19356         sigm=0.25d0*x
19357       return
19358       end function sigm
19359 !-----------------------------------------------------------------------------
19360 !-----------------------------------------------------------------------------
19361       subroutine alloc_ener_arrays
19362 !EL Allocation of arrays used by module energy
19363       use MD_data, only: mset
19364 !el local variables
19365       integer :: i,j
19366
19367       if(nres.lt.100) then
19368         maxconts=nres
19369       elseif(nres.lt.200) then
19370         maxconts=0.8*nres       ! Max. number of contacts per residue
19371       else
19372         maxconts=0.6*nres ! (maxconts=maxres/4)
19373       endif
19374       maxcont=12*nres   ! Max. number of SC contacts
19375       maxvar=6*nres     ! Max. number of variables
19376 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19377       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19378 !----------------------
19379 ! arrays in subroutine init_int_table
19380 !el#ifdef MPI
19381 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19382 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19383 !el#endif
19384       allocate(nint_gr(nres))
19385       allocate(nscp_gr(nres))
19386       allocate(ielstart(nres))
19387       allocate(ielend(nres))
19388 !(maxres)
19389       allocate(istart(nres,maxint_gr))
19390       allocate(iend(nres,maxint_gr))
19391 !(maxres,maxint_gr)
19392       allocate(iscpstart(nres,maxint_gr))
19393       allocate(iscpend(nres,maxint_gr))
19394 !(maxres,maxint_gr)
19395       allocate(ielstart_vdw(nres))
19396       allocate(ielend_vdw(nres))
19397 !(maxres)
19398
19399       allocate(lentyp(0:nfgtasks-1))
19400 !(0:maxprocs-1)
19401 !----------------------
19402 ! commom.contacts
19403 !      common /contacts/
19404       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19405       allocate(icont(2,maxcont))
19406 !(2,maxcont)
19407 !      common /contacts1/
19408       allocate(num_cont(0:nres+4))
19409 !(maxres)
19410       allocate(jcont(maxconts,nres))
19411 !(maxconts,maxres)
19412       allocate(facont(maxconts,nres))
19413 !(maxconts,maxres)
19414       allocate(gacont(3,maxconts,nres))
19415 !(3,maxconts,maxres)
19416 !      common /contacts_hb/
19417       allocate(gacontp_hb1(3,maxconts,nres))
19418       allocate(gacontp_hb2(3,maxconts,nres))
19419       allocate(gacontp_hb3(3,maxconts,nres))
19420       allocate(gacontm_hb1(3,maxconts,nres))
19421       allocate(gacontm_hb2(3,maxconts,nres))
19422       allocate(gacontm_hb3(3,maxconts,nres))
19423       allocate(gacont_hbr(3,maxconts,nres))
19424       allocate(grij_hb_cont(3,maxconts,nres))
19425 !(3,maxconts,maxres)
19426       allocate(facont_hb(maxconts,nres))
19427
19428       allocate(ees0p(maxconts,nres))
19429       allocate(ees0m(maxconts,nres))
19430       allocate(d_cont(maxconts,nres))
19431       allocate(ees0plist(maxconts,nres))
19432
19433 !(maxconts,maxres)
19434       allocate(num_cont_hb(nres))
19435 !(maxres)
19436       allocate(jcont_hb(maxconts,nres))
19437 !(maxconts,maxres)
19438 !      common /rotat/
19439       allocate(Ug(2,2,nres))
19440       allocate(Ugder(2,2,nres))
19441       allocate(Ug2(2,2,nres))
19442       allocate(Ug2der(2,2,nres))
19443 !(2,2,maxres)
19444       allocate(obrot(2,nres))
19445       allocate(obrot2(2,nres))
19446       allocate(obrot_der(2,nres))
19447       allocate(obrot2_der(2,nres))
19448 !(2,maxres)
19449 !      common /precomp1/
19450       allocate(mu(2,nres))
19451       allocate(muder(2,nres))
19452       allocate(Ub2(2,nres))
19453       Ub2(1,:)=0.0d0
19454       Ub2(2,:)=0.0d0
19455       allocate(Ub2der(2,nres))
19456       allocate(Ctobr(2,nres))
19457       allocate(Ctobrder(2,nres))
19458       allocate(Dtobr2(2,nres))
19459       allocate(Dtobr2der(2,nres))
19460 !(2,maxres)
19461       allocate(EUg(2,2,nres))
19462       allocate(EUgder(2,2,nres))
19463       allocate(CUg(2,2,nres))
19464       allocate(CUgder(2,2,nres))
19465       allocate(DUg(2,2,nres))
19466       allocate(Dugder(2,2,nres))
19467       allocate(DtUg2(2,2,nres))
19468       allocate(DtUg2der(2,2,nres))
19469 !(2,2,maxres)
19470 !      common /precomp2/
19471       allocate(Ug2Db1t(2,nres))
19472       allocate(Ug2Db1tder(2,nres))
19473       allocate(CUgb2(2,nres))
19474       allocate(CUgb2der(2,nres))
19475 !(2,maxres)
19476       allocate(EUgC(2,2,nres))
19477       allocate(EUgCder(2,2,nres))
19478       allocate(EUgD(2,2,nres))
19479       allocate(EUgDder(2,2,nres))
19480       allocate(DtUg2EUg(2,2,nres))
19481       allocate(Ug2DtEUg(2,2,nres))
19482 !(2,2,maxres)
19483       allocate(Ug2DtEUgder(2,2,2,nres))
19484       allocate(DtUg2EUgder(2,2,2,nres))
19485 !(2,2,2,maxres)
19486 !      common /rotat_old/
19487       allocate(costab(nres))
19488       allocate(sintab(nres))
19489       allocate(costab2(nres))
19490       allocate(sintab2(nres))
19491 !(maxres)
19492 !      common /dipmat/
19493       allocate(a_chuj(2,2,maxconts,nres))
19494 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19495       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19496 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19497 !      common /contdistrib/
19498       allocate(ncont_sent(nres))
19499       allocate(ncont_recv(nres))
19500
19501       allocate(iat_sent(nres))
19502 !(maxres)
19503       allocate(iint_sent(4,nres,nres))
19504       allocate(iint_sent_local(4,nres,nres))
19505 !(4,maxres,maxres)
19506       allocate(iturn3_sent(4,0:nres+4))
19507       allocate(iturn4_sent(4,0:nres+4))
19508       allocate(iturn3_sent_local(4,nres))
19509       allocate(iturn4_sent_local(4,nres))
19510 !(4,maxres)
19511       allocate(itask_cont_from(0:nfgtasks-1))
19512       allocate(itask_cont_to(0:nfgtasks-1))
19513 !(0:max_fg_procs-1)
19514
19515
19516
19517 !----------------------
19518 ! commom.deriv;
19519 !      common /derivat/
19520       allocate(dcdv(6,maxdim))
19521       allocate(dxdv(6,maxdim))
19522 !(6,maxdim)
19523       allocate(dxds(6,nres))
19524 !(6,maxres)
19525       allocate(gradx(3,-1:nres,0:2))
19526       allocate(gradc(3,-1:nres,0:2))
19527 !(3,maxres,2)
19528       allocate(gvdwx(3,-1:nres))
19529       allocate(gvdwc(3,-1:nres))
19530       allocate(gelc(3,-1:nres))
19531       allocate(gelc_long(3,-1:nres))
19532       allocate(gvdwpp(3,-1:nres))
19533       allocate(gvdwc_scpp(3,-1:nres))
19534       allocate(gradx_scp(3,-1:nres))
19535       allocate(gvdwc_scp(3,-1:nres))
19536       allocate(ghpbx(3,-1:nres))
19537       allocate(ghpbc(3,-1:nres))
19538       allocate(gradcorr(3,-1:nres))
19539       allocate(gradcorr_long(3,-1:nres))
19540       allocate(gradcorr5_long(3,-1:nres))
19541       allocate(gradcorr6_long(3,-1:nres))
19542       allocate(gcorr6_turn_long(3,-1:nres))
19543       allocate(gradxorr(3,-1:nres))
19544       allocate(gradcorr5(3,-1:nres))
19545       allocate(gradcorr6(3,-1:nres))
19546       allocate(gliptran(3,-1:nres))
19547       allocate(gliptranc(3,-1:nres))
19548       allocate(gliptranx(3,-1:nres))
19549       allocate(gshieldx(3,-1:nres))
19550       allocate(gshieldc(3,-1:nres))
19551       allocate(gshieldc_loc(3,-1:nres))
19552       allocate(gshieldx_ec(3,-1:nres))
19553       allocate(gshieldc_ec(3,-1:nres))
19554       allocate(gshieldc_loc_ec(3,-1:nres))
19555       allocate(gshieldx_t3(3,-1:nres))
19556       allocate(gshieldc_t3(3,-1:nres))
19557       allocate(gshieldc_loc_t3(3,-1:nres))
19558       allocate(gshieldx_t4(3,-1:nres))
19559       allocate(gshieldc_t4(3,-1:nres))
19560       allocate(gshieldc_loc_t4(3,-1:nres))
19561       allocate(gshieldx_ll(3,-1:nres))
19562       allocate(gshieldc_ll(3,-1:nres))
19563       allocate(gshieldc_loc_ll(3,-1:nres))
19564       allocate(grad_shield(3,-1:nres))
19565       allocate(gg_tube_sc(3,-1:nres))
19566       allocate(gg_tube(3,-1:nres))
19567       allocate(gradafm(3,-1:nres))
19568       allocate(gradb_nucl(3,-1:nres))
19569       allocate(gradbx_nucl(3,-1:nres))
19570 !(3,maxres)
19571       allocate(grad_shield_side(3,50,nres))
19572       allocate(grad_shield_loc(3,50,nres))
19573 ! grad for shielding surroing
19574       allocate(gloc(0:maxvar,0:2))
19575       allocate(gloc_x(0:maxvar,2))
19576 !(maxvar,2)
19577       allocate(gel_loc(3,-1:nres))
19578       allocate(gel_loc_long(3,-1:nres))
19579       allocate(gcorr3_turn(3,-1:nres))
19580       allocate(gcorr4_turn(3,-1:nres))
19581       allocate(gcorr6_turn(3,-1:nres))
19582       allocate(gradb(3,-1:nres))
19583       allocate(gradbx(3,-1:nres))
19584 !(3,maxres)
19585       allocate(gel_loc_loc(maxvar))
19586       allocate(gel_loc_turn3(maxvar))
19587       allocate(gel_loc_turn4(maxvar))
19588       allocate(gel_loc_turn6(maxvar))
19589       allocate(gcorr_loc(maxvar))
19590       allocate(g_corr5_loc(maxvar))
19591       allocate(g_corr6_loc(maxvar))
19592 !(maxvar)
19593       allocate(gsccorc(3,-1:nres))
19594       allocate(gsccorx(3,-1:nres))
19595 !(3,maxres)
19596       allocate(gsccor_loc(-1:nres))
19597 !(maxres)
19598       allocate(dtheta(3,2,-1:nres))
19599 !(3,2,maxres)
19600       allocate(gscloc(3,-1:nres))
19601       allocate(gsclocx(3,-1:nres))
19602 !(3,maxres)
19603       allocate(dphi(3,3,-1:nres))
19604       allocate(dalpha(3,3,-1:nres))
19605       allocate(domega(3,3,-1:nres))
19606 !(3,3,maxres)
19607 !      common /deriv_scloc/
19608       allocate(dXX_C1tab(3,nres))
19609       allocate(dYY_C1tab(3,nres))
19610       allocate(dZZ_C1tab(3,nres))
19611       allocate(dXX_Ctab(3,nres))
19612       allocate(dYY_Ctab(3,nres))
19613       allocate(dZZ_Ctab(3,nres))
19614       allocate(dXX_XYZtab(3,nres))
19615       allocate(dYY_XYZtab(3,nres))
19616       allocate(dZZ_XYZtab(3,nres))
19617 !(3,maxres)
19618 !      common /mpgrad/
19619       allocate(jgrad_start(nres))
19620       allocate(jgrad_end(nres))
19621 !(maxres)
19622 !----------------------
19623
19624 !      common /indices/
19625       allocate(ibond_displ(0:nfgtasks-1))
19626       allocate(ibond_count(0:nfgtasks-1))
19627       allocate(ithet_displ(0:nfgtasks-1))
19628       allocate(ithet_count(0:nfgtasks-1))
19629       allocate(iphi_displ(0:nfgtasks-1))
19630       allocate(iphi_count(0:nfgtasks-1))
19631       allocate(iphi1_displ(0:nfgtasks-1))
19632       allocate(iphi1_count(0:nfgtasks-1))
19633       allocate(ivec_displ(0:nfgtasks-1))
19634       allocate(ivec_count(0:nfgtasks-1))
19635       allocate(iset_displ(0:nfgtasks-1))
19636       allocate(iset_count(0:nfgtasks-1))
19637       allocate(iint_count(0:nfgtasks-1))
19638       allocate(iint_displ(0:nfgtasks-1))
19639 !(0:max_fg_procs-1)
19640 !----------------------
19641 ! common.MD
19642 !      common /mdgrad/
19643       allocate(gcart(3,-1:nres))
19644       allocate(gxcart(3,-1:nres))
19645 !(3,0:MAXRES)
19646       allocate(gradcag(3,-1:nres))
19647       allocate(gradxag(3,-1:nres))
19648 !(3,MAXRES)
19649 !      common /back_constr/
19650 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19651       allocate(dutheta(nres))
19652       allocate(dugamma(nres))
19653 !(maxres)
19654       allocate(duscdiff(3,nres))
19655       allocate(duscdiffx(3,nres))
19656 !(3,maxres)
19657 !el i io:read_fragments
19658 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19659 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19660 !      common /qmeas/
19661 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19662 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19663       allocate(mset(0:nprocs))  !(maxprocs/20)
19664       mset(:)=0
19665 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19666 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19667       allocate(dUdconst(3,0:nres))
19668       allocate(dUdxconst(3,0:nres))
19669       allocate(dqwol(3,0:nres))
19670       allocate(dxqwol(3,0:nres))
19671 !(3,0:MAXRES)
19672 !----------------------
19673 ! common.sbridge
19674 !      common /sbridge/ in io_common: read_bridge
19675 !el    allocate((:),allocatable :: iss  !(maxss)
19676 !      common /links/  in io_common: read_bridge
19677 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19678 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19679 !      common /dyn_ssbond/
19680 ! and side-chain vectors in theta or phi.
19681       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19682 !(maxres,maxres)
19683 !      do i=1,nres
19684 !        do j=i+1,nres
19685       dyn_ssbond_ij(:,:)=1.0d300
19686 !        enddo
19687 !      enddo
19688
19689 !      if (nss.gt.0) then
19690         allocate(idssb(maxdim),jdssb(maxdim))
19691 !        allocate(newihpb(nss),newjhpb(nss))
19692 !(maxdim)
19693 !      endif
19694       allocate(ishield_list(nres))
19695       allocate(shield_list(50,nres))
19696       allocate(dyn_ss_mask(nres))
19697       allocate(fac_shield(nres))
19698       allocate(enetube(nres*2))
19699       allocate(enecavtube(nres*2))
19700
19701 !(maxres)
19702       dyn_ss_mask(:)=.false.
19703 !----------------------
19704 ! common.sccor
19705 ! Parameters of the SCCOR term
19706 !      common/sccor/
19707 !el in io_conf: parmread
19708 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
19709 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
19710 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
19711 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
19712 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
19713 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
19714 !      allocate(vlor1sccor(maxterm_sccor,20,20))
19715 !      allocate(vlor2sccor(maxterm_sccor,20,20))
19716 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
19717 !----------------
19718       allocate(gloc_sc(3,0:2*nres,0:10))
19719 !(3,0:maxres2,10)maxres2=2*maxres
19720       allocate(dcostau(3,3,3,2*nres))
19721       allocate(dsintau(3,3,3,2*nres))
19722       allocate(dtauangle(3,3,3,2*nres))
19723       allocate(dcosomicron(3,3,3,2*nres))
19724       allocate(domicron(3,3,3,2*nres))
19725 !(3,3,3,maxres2)maxres2=2*maxres
19726 !----------------------
19727 ! common.var
19728 !      common /restr/
19729       allocate(varall(maxvar))
19730 !(maxvar)(maxvar=6*maxres)
19731       allocate(mask_theta(nres))
19732       allocate(mask_phi(nres))
19733       allocate(mask_side(nres))
19734 !(maxres)
19735 !----------------------
19736 ! common.vectors
19737 !      common /vectors/
19738       allocate(uy(3,nres))
19739       allocate(uz(3,nres))
19740 !(3,maxres)
19741       allocate(uygrad(3,3,2,nres))
19742       allocate(uzgrad(3,3,2,nres))
19743 !(3,3,2,maxres)
19744
19745       return
19746       end subroutine alloc_ener_arrays
19747 !-----------------------------------------------------------------
19748       subroutine ebond_nucl(estr_nucl)
19749 !c
19750 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
19751 !c
19752
19753       real(kind=8),dimension(3) :: u,ud
19754       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
19755       real(kind=8) :: estr_nucl,diff
19756       integer :: iti,i,j,k,nbi
19757       estr_nucl=0.0d0
19758 !C      print *,"I enter ebond"
19759       if (energy_dec) &
19760       write (iout,*) "ibondp_start,ibondp_end",&
19761        ibondp_nucl_start,ibondp_nucl_end
19762       do i=ibondp_nucl_start,ibondp_nucl_end
19763         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
19764          itype(i,2).eq.ntyp1_molec(2)) cycle
19765 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
19766 !          do j=1,3
19767 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
19768 !     &      *dc(j,i-1)/vbld(i)
19769 !          enddo
19770 !          if (energy_dec) write(iout,*)
19771 !     &       "estr1",i,vbld(i),distchainmax,
19772 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
19773
19774           diff = vbld(i)-vbldp0_nucl
19775           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
19776           vbldp0_nucl,diff,AKP_nucl*diff*diff
19777           estr_nucl=estr_nucl+diff*diff
19778           print *,estr_nucl
19779           do j=1,3
19780             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
19781           enddo
19782 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
19783       enddo
19784       estr_nucl=0.5d0*AKP_nucl*estr_nucl
19785       print *,"partial sum", estr_nucl,AKP_nucl
19786
19787       if (energy_dec) &
19788       write (iout,*) "ibondp_start,ibondp_end",&
19789        ibond_nucl_start,ibond_nucl_end
19790
19791       do i=ibond_nucl_start,ibond_nucl_end
19792 !C        print *, "I am stuck",i
19793         iti=itype(i,2)
19794         if (iti.eq.ntyp1_molec(2)) cycle
19795           nbi=nbondterm_nucl(iti)
19796 !C        print *,iti,nbi
19797           if (nbi.eq.1) then
19798             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
19799
19800             if (energy_dec) &
19801            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
19802            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
19803             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
19804             print *,estr_nucl
19805             do j=1,3
19806               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
19807             enddo
19808           else
19809             do j=1,nbi
19810               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
19811               ud(j)=aksc_nucl(j,iti)*diff
19812               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
19813             enddo
19814             uprod=u(1)
19815             do j=2,nbi
19816               uprod=uprod*u(j)
19817             enddo
19818             usum=0.0d0
19819             usumsqder=0.0d0
19820             do j=1,nbi
19821               uprod1=1.0d0
19822               uprod2=1.0d0
19823               do k=1,nbi
19824                 if (k.ne.j) then
19825                   uprod1=uprod1*u(k)
19826                   uprod2=uprod2*u(k)*u(k)
19827                 endif
19828               enddo
19829               usum=usum+uprod1
19830               usumsqder=usumsqder+ud(j)*uprod2
19831             enddo
19832             estr_nucl=estr_nucl+uprod/usum
19833             do j=1,3
19834              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
19835             enddo
19836         endif
19837       enddo
19838 !C      print *,"I am about to leave ebond"
19839       return
19840       end subroutine ebond_nucl
19841
19842 !-----------------------------------------------------------------------------
19843       subroutine ebend_nucl(etheta_nucl)
19844       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
19845       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
19846       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
19847       logical :: lprn=.true., lprn1=.false.
19848 !el local variables
19849       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
19850       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
19851       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
19852 ! local variables for constrains
19853       real(kind=8) :: difi,thetiii
19854        integer itheta
19855       etheta_nucl=0.0D0
19856       print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
19857       do i=ithet_nucl_start,ithet_nucl_end
19858         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
19859         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
19860         (itype(i,2).eq.ntyp1_molec(2))) cycle
19861         dethetai=0.0d0
19862         dephii=0.0d0
19863         dephii1=0.0d0
19864         theti2=0.5d0*theta(i)
19865         ityp2=ithetyp_nucl(itype(i-1,2))
19866         do k=1,nntheterm_nucl
19867           coskt(k)=dcos(k*theti2)
19868           sinkt(k)=dsin(k*theti2)
19869         enddo
19870         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
19871 #ifdef OSF
19872           phii=phi(i)
19873           if (phii.ne.phii) phii=150.0
19874 #else
19875           phii=phi(i)
19876 #endif
19877           ityp1=ithetyp_nucl(itype(i-2,2))
19878           do k=1,nsingle_nucl
19879             cosph1(k)=dcos(k*phii)
19880             sinph1(k)=dsin(k*phii)
19881           enddo
19882         else
19883           phii=0.0d0
19884           ityp1=nthetyp_nucl+1
19885           do k=1,nsingle_nucl
19886             cosph1(k)=0.0d0
19887             sinph1(k)=0.0d0
19888           enddo
19889         endif
19890
19891         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
19892 #ifdef OSF
19893           phii1=phi(i+1)
19894           if (phii1.ne.phii1) phii1=150.0
19895           phii1=pinorm(phii1)
19896 #else
19897           phii1=phi(i+1)
19898 #endif
19899           ityp3=ithetyp_nucl(itype(i,2))
19900           do k=1,nsingle_nucl
19901             cosph2(k)=dcos(k*phii1)
19902             sinph2(k)=dsin(k*phii1)
19903           enddo
19904         else
19905           phii1=0.0d0
19906           ityp3=nthetyp_nucl+1
19907           do k=1,nsingle_nucl
19908             cosph2(k)=0.0d0
19909             sinph2(k)=0.0d0
19910           enddo
19911         endif
19912         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
19913         do k=1,ndouble_nucl
19914           do l=1,k-1
19915             ccl=cosph1(l)*cosph2(k-l)
19916             ssl=sinph1(l)*sinph2(k-l)
19917             scl=sinph1(l)*cosph2(k-l)
19918             csl=cosph1(l)*sinph2(k-l)
19919             cosph1ph2(l,k)=ccl-ssl
19920             cosph1ph2(k,l)=ccl+ssl
19921             sinph1ph2(l,k)=scl+csl
19922             sinph1ph2(k,l)=scl-csl
19923           enddo
19924         enddo
19925         if (lprn) then
19926         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
19927          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
19928         write (iout,*) "coskt and sinkt",nntheterm_nucl
19929         do k=1,nntheterm_nucl
19930           write (iout,*) k,coskt(k),sinkt(k)
19931         enddo
19932         endif
19933         do k=1,ntheterm_nucl
19934           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
19935           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
19936            *coskt(k)
19937           if (lprn)&
19938          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
19939           " ethetai",ethetai
19940         enddo
19941         if (lprn) then
19942         write (iout,*) "cosph and sinph"
19943         do k=1,nsingle_nucl
19944           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
19945         enddo
19946         write (iout,*) "cosph1ph2 and sinph2ph2"
19947         do k=2,ndouble_nucl
19948           do l=1,k-1
19949             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
19950               sinph1ph2(l,k),sinph1ph2(k,l)
19951           enddo
19952         enddo
19953         write(iout,*) "ethetai",ethetai
19954         endif
19955         do m=1,ntheterm2_nucl
19956           do k=1,nsingle_nucl
19957             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
19958               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
19959               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
19960               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
19961             ethetai=ethetai+sinkt(m)*aux
19962             dethetai=dethetai+0.5d0*m*aux*coskt(m)
19963             dephii=dephii+k*sinkt(m)*(&
19964                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
19965                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
19966             dephii1=dephii1+k*sinkt(m)*(&
19967                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
19968                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
19969             if (lprn) &
19970            write (iout,*) "m",m," k",k," bbthet",&
19971               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
19972               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
19973               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
19974               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
19975           enddo
19976         enddo
19977         if (lprn) &
19978         write(iout,*) "ethetai",ethetai
19979         do m=1,ntheterm3_nucl
19980           do k=2,ndouble_nucl
19981             do l=1,k-1
19982               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
19983                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
19984                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
19985                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
19986               ethetai=ethetai+sinkt(m)*aux
19987               dethetai=dethetai+0.5d0*m*coskt(m)*aux
19988               dephii=dephii+l*sinkt(m)*(&
19989                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
19990                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
19991                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
19992                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
19993               dephii1=dephii1+(k-l)*sinkt(m)*( &
19994                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
19995                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
19996                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
19997                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
19998               if (lprn) then
19999               write (iout,*) "m",m," k",k," l",l," ffthet", &
20000                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20001                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20002                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20003                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20004               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20005                  cosph1ph2(k,l)*sinkt(m),&
20006                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20007               endif
20008             enddo
20009           enddo
20010         enddo
20011 10      continue
20012         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20013         i,theta(i)*rad2deg,phii*rad2deg, &
20014         phii1*rad2deg,ethetai
20015         etheta_nucl=etheta_nucl+ethetai
20016         print *,i,"partial sum",etheta_nucl
20017         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20018         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20019         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20020       enddo
20021       return
20022       end subroutine ebend_nucl
20023 !----------------------------------------------------
20024       subroutine etor_nucl(etors_nucl)
20025 !      implicit real*8 (a-h,o-z)
20026 !      include 'DIMENSIONS'
20027 !      include 'COMMON.VAR'
20028 !      include 'COMMON.GEO'
20029 !      include 'COMMON.LOCAL'
20030 !      include 'COMMON.TORSION'
20031 !      include 'COMMON.INTERACT'
20032 !      include 'COMMON.DERIV'
20033 !      include 'COMMON.CHAIN'
20034 !      include 'COMMON.NAMES'
20035 !      include 'COMMON.IOUNITS'
20036 !      include 'COMMON.FFIELD'
20037 !      include 'COMMON.TORCNSTR'
20038 !      include 'COMMON.CONTROL'
20039       real(kind=8) :: etors_nucl,edihcnstr
20040       logical :: lprn
20041 !el local variables
20042       integer :: i,j,iblock,itori,itori1
20043       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20044                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20045 ! Set lprn=.true. for debugging
20046       lprn=.false.
20047 !     lprn=.true.
20048       etors_nucl=0.0D0
20049       print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20050       do i=iphi_nucl_start,iphi_nucl_end
20051         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20052              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20053              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20054         etors_ii=0.0D0
20055         itori=itortyp_nucl(itype(i-2,2))
20056         itori1=itortyp_nucl(itype(i-1,2))
20057         phii=phi(i)
20058          print *,i,itori,itori1
20059         gloci=0.0D0
20060 !C Regular cosine and sine terms
20061         do j=1,nterm_nucl(itori,itori1)
20062           v1ij=v1_nucl(j,itori,itori1)
20063           v2ij=v2_nucl(j,itori,itori1)
20064           cosphi=dcos(j*phii)
20065           sinphi=dsin(j*phii)
20066           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20067           if (energy_dec) etors_ii=etors_ii+&
20068                      v1ij*cosphi+v2ij*sinphi
20069           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20070         enddo
20071 !C Lorentz terms
20072 !C                         v1
20073 !C  E = SUM ----------------------------------- - v1
20074 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20075 !C
20076         cosphi=dcos(0.5d0*phii)
20077         sinphi=dsin(0.5d0*phii)
20078         do j=1,nlor_nucl(itori,itori1)
20079           vl1ij=vlor1_nucl(j,itori,itori1)
20080           vl2ij=vlor2_nucl(j,itori,itori1)
20081           vl3ij=vlor3_nucl(j,itori,itori1)
20082           pom=vl2ij*cosphi+vl3ij*sinphi
20083           pom1=1.0d0/(pom*pom+1.0d0)
20084           etors_nucl=etors_nucl+vl1ij*pom1
20085           if (energy_dec) etors_ii=etors_ii+ &
20086                      vl1ij*pom1
20087           pom=-pom*pom1*pom1
20088           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20089         enddo
20090 !C Subtract the constant term
20091         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20092           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20093               'etor',i,etors_ii-v0_nucl(itori,itori1)
20094         if (lprn) &
20095        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20096        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20097        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20098         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20099 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20100       enddo
20101       return
20102       end subroutine etor_nucl
20103
20104 !-----------------------------------------------------------------------------
20105 !-----------------------------------------------------------------------------
20106       end module energy