source/unres/energy.f90

   1       module energy
   2 !-----------------------------------------------------------------------------
   3       use io_units
   4       use names
   5       use math
   6       use MPI_data
   7       use energy_data
   8       use control_data
   9       use geometry_data
  10       use geometry
  11 !
  12       implicit none
  13 !-----------------------------------------------------------------------------
  14 ! Max. number of contacts per residue
  15 !      integer :: maxconts
  16 !-----------------------------------------------------------------------------
  17 ! Max. number of derivatives of virtual-bond and side-chain vectors in theta
  18 ! or phi.
  19 !      integer :: maxdim
  20 !-----------------------------------------------------------------------------
  21 ! Max. number of SC contacts
  22 !      integer :: maxcont
  23 !-----------------------------------------------------------------------------
  24 ! Max. number of variables
  25       integer :: maxvar
  26 !-----------------------------------------------------------------------------
  27 ! Max number of torsional terms in SCCOR  in control_data
  28 !      integer,parameter :: maxterm_sccor=6
  29 !-----------------------------------------------------------------------------
  30 ! Maximum number of SC local term fitting function coefficiants
  31       integer,parameter :: maxsccoef=65
  32 ! Maximum number of local shielding effectors
  33       integer,parameter :: maxcontsshi=50
  34 !-----------------------------------------------------------------------------
  35 ! commom.calc common/calc/
  36 !-----------------------------------------------------------------------------
  37 ! commom.contacts
  38 !      common /contacts/
  39 ! Change 12/1/95 - common block CONTACTS1 included.
  40 !      common /contacts1/
  41
  42       integer,dimension(:),allocatable :: num_cont      !(maxres)
  43       integer,dimension(:,:),allocatable :: jcont       !(maxconts,maxres)
  44       real(kind=8),dimension(:,:),allocatable :: facont,ees0plist       !(maxconts,maxres)
  45       real(kind=8),dimension(:,:,:),allocatable :: gacont       !(3,maxconts,maxres)
  46       integer,dimension(:),allocatable :: ishield_list
  47       integer,dimension(:,:),allocatable ::  shield_list
  48       real(kind=8),dimension(:),allocatable :: enetube,enecavtube
  49 !
  50 ! 12/26/95 - H-bonding contacts
  51 !      common /contacts_hb/
  52       real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,&
  53        gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont  !(3,maxconts,maxres)
  54       real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,&
  55         ees0m,d_cont    !(maxconts,maxres)
  56       integer,dimension(:),allocatable :: num_cont_hb   !(maxres)
  57       integer,dimension(:,:),allocatable :: jcont_hb    !(maxconts,maxres)
  58 ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
  59 !         interactions
  60 ! 7/25/08 commented out; not needed when cumulants used
  61 ! Interactions of pseudo-dipoles generated by loc-el interactions.
  62 !  common /dipint/
  63       real(kind=8),dimension(:,:,:),allocatable :: dip,&
  64          dipderg        !(4,maxconts,maxres)
  65       real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres)
  66 ! 10/30/99 Added other pre-computed vectors and matrices needed
  67 !          to calculate three - six-order el-loc correlation terms
  68 ! common /rotat/
  69       real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der  !(2,2,maxres)
  70       real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,&
  71        obrot2_der       !(2,maxres)
  72 !
  73 ! This common block contains vectors and matrices dependent on a single
  74 ! amino-acid residue.
  75 !      common /precomp1/
  76       real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,&
  77        Ctobr,Ctobrder,Dtobr2,Dtobr2der  !(2,maxres)
  78       real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,&
  79        CUgder,DUg,Dugder,DtUg2,DtUg2der !(2,2,maxres)
  80 ! This common block contains vectors and matrices dependent on two
  81 ! consecutive amino-acid residues.
  82 !      common /precomp2/
  83       real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,&
  84        CUgb2,CUgb2der   !(2,maxres)
  85       real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,&
  86        EUgD,EUgDder,DtUg2EUg,Ug2DtEUg   !(2,2,maxres)
  87       real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,&
  88        DtUg2EUgder      !(2,2,2,maxres)
  89 !      common /rotat_old/
  90       real(kind=8),dimension(:),allocatable :: costab,sintab,&
  91        costab2,sintab2  !(maxres)
  92 ! This common block contains dipole-interaction matrices and their
  93 ! Cartesian derivatives.
  94 !      common /dipmat/
  95       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj     !(2,2,maxconts,maxres)
  96       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der     !(2,2,3,5,maxconts,maxres)
  97 !      common /diploc/
  98       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
  99        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
 100       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
 101        ADtEA1derg,AEAb2derg
 102       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
 103        AECAderx,ADtEAderx,ADtEA1derx
 104       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
 105       real(kind=8),dimension(3,2) :: g_contij
 106       real(kind=8) :: ekont
 107 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 108 !   RE: Parallelization of 4th and higher order loc-el correlations
 109 !      common /contdistrib/
 110       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 111 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 112 !-----------------------------------------------------------------------------
 113 ! commom.deriv;
 114 !      common /derivat/
 115 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 116 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 117 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 118       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 119         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 120         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 121         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6,gliptran,gliptranc,&
 122         gliptranx, &
 123         gshieldx,gshieldc,gshieldc_loc,gshieldx_ec,&
 124         gshieldc_ec,gshieldc_loc_ec,gshieldx_t3, &
 125         gshieldc_t3,gshieldc_loc_t3,gshieldx_t4,gshieldc_t4, &
 126         gshieldc_loc_t4,gshieldx_ll,gshieldc_ll,gshieldc_loc_ll,&
 127         grad_shield,gg_tube,gg_tube_sc,gradafm !(3,maxres)
 128 !-----------------------------NUCLEIC GRADIENT
 129       real(kind=8),dimension(:,:),allocatable  ::gradb_nucl,gradbx_nucl, &
 130         gvdwpsb1,gelpp,gvdwpsb,gelsbc,gelsbx,gvdwsbx,gvdwsbc
 131 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 132       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 133         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 134       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 135         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 136         g_corr6_loc     !(maxvar)
 137       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 138       real(kind=8),dimension(:),allocatable :: gsccor_loc       !(maxres)
 139 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 140       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 141 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 142       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 143          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 144 !      integer :: nfl,icg
 145 !      common /deriv_loc/
 146       real(kind=8), dimension(:),allocatable :: fac_shield
 147       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 148 !      common /deriv_scloc/
 149       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 150        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 151        dZZ_XYZtab       !(3,maxres)
 152 !-----------------------------------------------------------------------------
 153 ! common.maxgrad
 154 !      common /maxgrad/
 155       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 156        gradb_max,ghpbc_max,&
 157        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 158        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 159        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 160        gsccorx_max,gsclocx_max
 161 !-----------------------------------------------------------------------------
 162 ! common.MD
 163 !      common /back_constr/
 164       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 165       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 166 !      common /qmeas/
 167       real(kind=8) :: Ucdfrag,Ucdpair
 168       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 169        dqwol,dxqwol     !(3,0:MAXRES)
 170 !-----------------------------------------------------------------------------
 171 ! common.sbridge
 172 !      common /dyn_ssbond/
 173       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 174 !-----------------------------------------------------------------------------
 175 ! common.sccor
 176 ! Parameters of the SCCOR term
 177 !      common/sccor/
 178       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 179        dcosomicron,domicron     !(3,3,3,maxres2)
 180 !-----------------------------------------------------------------------------
 181 ! common.vectors
 182 !      common /vectors/
 183       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 184       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 185 !-----------------------------------------------------------------------------
 186 ! common /przechowalnia/
 187       real(kind=8),dimension(:,:,:),allocatable :: zapas !(max_dim,maxconts,max_fg_procs)
 188       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 189 !-----------------------------------------------------------------------------
 190 !-----------------------------------------------------------------------------
 191 !
 192 !
 193 !-----------------------------------------------------------------------------
 194       contains
 195 !-----------------------------------------------------------------------------
 196 ! energy_p_new_barrier.F
 197 !-----------------------------------------------------------------------------
 198       subroutine etotal(energia)
 199 !      implicit real*8 (a-h,o-z)
 200 !      include 'DIMENSIONS'
 201       use MD_data
 202 #ifndef ISNAN
 203       external proc_proc
 204 #ifdef WINPGI
 205 !MS$ATTRIBUTES C ::  proc_proc
 206 #endif
 207 #endif
 208 #ifdef MPI
 209       include "mpif.h"
 210 #endif
 211 !      include 'COMMON.SETUP'
 212 !      include 'COMMON.IOUNITS'
 213       real(kind=8),dimension(0:n_ene) :: energia
 214 !      include 'COMMON.LOCAL'
 215 !      include 'COMMON.FFIELD'
 216 !      include 'COMMON.DERIV'
 217 !      include 'COMMON.INTERACT'
 218 !      include 'COMMON.SBRIDGE'
 219 !      include 'COMMON.CHAIN'
 220 !      include 'COMMON.VAR'
 221 !      include 'COMMON.MD'
 222 !      include 'COMMON.CONTROL'
 223 !      include 'COMMON.TIME1'
 224       real(kind=8) :: time00
 225 !el local variables
 226       integer :: n_corr,n_corr1,ierror
 227       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 228       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 229       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 230                       Eafmforce,ethetacnstr
 231       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 232 ! now energies for nulceic alone parameters
 233       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 234                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 235                       ecorr3_nucl
 236 #ifdef MPI
 237       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 238 ! shielding effect varibles for MPI
 239 !      real(kind=8)   fac_shieldbuf(maxres),
 240 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 241 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 242 !     & grad_shieldbuf(3,-1:maxres)
 243 !       integer ishield_listbuf(maxres),
 244 !     &shield_listbuf(maxcontsshi,maxres)
 245
 246 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 247 !     & " nfgtasks",nfgtasks
 248       if (nfgtasks.gt.1) then
 249         time00=MPI_Wtime()
 250 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 251         if (fg_rank.eq.0) then
 252           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 253 !          print *,"Processor",myrank," BROADCAST iorder"
 254 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 255 ! FG slaves as WEIGHTS array.
 256           weights_(1)=wsc
 257           weights_(2)=wscp
 258           weights_(3)=welec
 259           weights_(4)=wcorr
 260           weights_(5)=wcorr5
 261           weights_(6)=wcorr6
 262           weights_(7)=wel_loc
 263           weights_(8)=wturn3
 264           weights_(9)=wturn4
 265           weights_(10)=wturn6
 266           weights_(11)=wang
 267           weights_(12)=wscloc
 268           weights_(13)=wtor
 269           weights_(14)=wtor_d
 270           weights_(15)=wstrain
 271           weights_(16)=wvdwpp
 272           weights_(17)=wbond
 273           weights_(18)=scal14
 274           weights_(21)=wsccor
 275 ! FG Master broadcasts the WEIGHTS_ array
 276           call MPI_Bcast(weights_(1),n_ene,&
 277              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 278         else
 279 ! FG slaves receive the WEIGHTS array
 280           call MPI_Bcast(weights(1),n_ene,&
 281               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 282           wsc=weights(1)
 283           wscp=weights(2)
 284           welec=weights(3)
 285           wcorr=weights(4)
 286           wcorr5=weights(5)
 287           wcorr6=weights(6)
 288           wel_loc=weights(7)
 289           wturn3=weights(8)
 290           wturn4=weights(9)
 291           wturn6=weights(10)
 292           wang=weights(11)
 293           wscloc=weights(12)
 294           wtor=weights(13)
 295           wtor_d=weights(14)
 296           wstrain=weights(15)
 297           wvdwpp=weights(16)
 298           wbond=weights(17)
 299           scal14=weights(18)
 300           wsccor=weights(21)
 301         endif
 302         time_Bcast=time_Bcast+MPI_Wtime()-time00
 303         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 304 !        call chainbuild_cart
 305       endif
 306 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 307 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 308 #else
 309 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 310 !        call int_from_cart1(.false.)
 311 !      endif
 312 #endif
 313 #ifdef TIMING
 314       time00=MPI_Wtime()
 315 #endif
 316 !
 317 ! Compute the side-chain and electrostatic interaction energy
 318 !        print *, "Before EVDW"
 319 !      goto (101,102,103,104,105,106) ipot
 320       select case(ipot)
 321 ! Lennard-Jones potential.
 322 !  101 call elj(evdw)
 323        case (1)
 324          call elj(evdw)
 325 !d    print '(a)','Exit ELJcall el'
 326 !      goto 107
 327 ! Lennard-Jones-Kihara potential (shifted).
 328 !  102 call eljk(evdw)
 329        case (2)
 330          call eljk(evdw)
 331 !      goto 107
 332 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 333 !  103 call ebp(evdw)
 334        case (3)
 335          call ebp(evdw)
 336 !      goto 107
 337 ! Gay-Berne potential (shifted LJ, angular dependence).
 338 !  104 call egb(evdw)
 339        case (4)
 340          call egb(evdw)
 341 !      goto 107
 342 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 343 !  105 call egbv(evdw)
 344        case (5)
 345          call egbv(evdw)
 346 !      goto 107
 347 ! Soft-sphere potential
 348 !  106 call e_softsphere(evdw)
 349        case (6)
 350          call e_softsphere(evdw)
 351 !
 352 ! Calculate electrostatic (H-bonding) energy of the main chain.
 353 !
 354 !  107 continue
 355        case default
 356          write(iout,*)"Wrong ipot"
 357 !         return
 358 !   50 continue
 359       end select
 360 !      continue
 361 !        print *,"after EGB"
 362 ! shielding effect
 363        if (shield_mode.eq.2) then
 364                  call set_shield_fac2
 365        endif
 366        print *,"AFTER EGB",ipot,evdw
 367 !mc
 368 !mc Sep-06: egb takes care of dynamic ss bonds too
 369 !mc
 370 !      if (dyn_ss) call dyn_set_nss
 371 !      print *,"Processor",myrank," computed USCSC"
 372 #ifdef TIMING
 373       time01=MPI_Wtime()
 374 #endif
 375       call vec_and_deriv
 376 #ifdef TIMING
 377       time_vec=time_vec+MPI_Wtime()-time01
 378 #endif
 379 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 380       if (ipot.lt.6) then
 381 #ifdef SPLITELE
 382 !         print *,"after ipot if", ipot
 383          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 384              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 385              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 386              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 387 #else
 388          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 389              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 390              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 391              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 392 #endif
 393 !            print *,"just befor eelec call"
 394             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 395 !         write (iout,*) "ELEC calc"
 396          else
 397             ees=0.0d0
 398             evdw1=0.0d0
 399             eel_loc=0.0d0
 400             eello_turn3=0.0d0
 401             eello_turn4=0.0d0
 402          endif
 403       else
 404 !        write (iout,*) "Soft-spheer ELEC potential"
 405         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 406          eello_turn4)
 407       endif
 408 !      print *,"Processor",myrank," computed UELEC"
 409 !
 410 ! Calculate excluded-volume interaction energy between peptide groups
 411 ! and side chains.
 412 !
 413 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 414
 415       if (ipot.lt.6) then
 416        if(wscp.gt.0d0) then
 417         call escp(evdw2,evdw2_14)
 418        else
 419         evdw2=0
 420         evdw2_14=0
 421        endif
 422       else
 423 !        write (iout,*) "Soft-sphere SCP potential"
 424         call escp_soft_sphere(evdw2,evdw2_14)
 425       endif
 426 !       write(iout,*) "in etotal before ebond",ipot
 427
 428 !
 429 ! Calculate the bond-stretching energy
 430 !
 431       call ebond(estr)
 432        print *,"EBOND",estr
 433 !       write(iout,*) "in etotal afer ebond",ipot
 434
 435 !
 436 ! Calculate the disulfide-bridge and other energy and the contributions
 437 ! from other distance constraints.
 438 !      print *,'Calling EHPB'
 439       call edis(ehpb)
 440 !elwrite(iout,*) "in etotal afer edis",ipot
 441 !      print *,'EHPB exitted succesfully.'
 442 !
 443 ! Calculate the virtual-bond-angle energy.
 444 !
 445       if (wang.gt.0d0) then
 446         call ebend(ebe,ethetacnstr)
 447       else
 448         ebe=0
 449       endif
 450 !      print *,"Processor",myrank," computed UB"
 451 !
 452 ! Calculate the SC local energy.
 453 !
 454       call esc(escloc)
 455 !elwrite(iout,*) "in etotal afer esc",ipot
 456 !      print *,"Processor",myrank," computed USC"
 457 !
 458 ! Calculate the virtual-bond torsional energy.
 459 !
 460 !d    print *,'nterm=',nterm
 461       if (wtor.gt.0) then
 462        call etor(etors,edihcnstr)
 463       else
 464        etors=0
 465        edihcnstr=0
 466       endif
 467 !      print *,"Processor",myrank," computed Utor"
 468 !
 469 ! 6/23/01 Calculate double-torsional energy
 470 !
 471 !elwrite(iout,*) "in etotal",ipot
 472       if (wtor_d.gt.0) then
 473        call etor_d(etors_d)
 474       else
 475        etors_d=0
 476       endif
 477 !      print *,"Processor",myrank," computed Utord"
 478 !
 479 ! 21/5/07 Calculate local sicdechain correlation energy
 480 !
 481       if (wsccor.gt.0.0d0) then
 482         call eback_sc_corr(esccor)
 483       else
 484         esccor=0.0d0
 485       endif
 486 !      print *,"Processor",myrank," computed Usccorr"
 487 !
 488 ! 12/1/95 Multi-body terms
 489 !
 490       n_corr=0
 491       n_corr1=0
 492       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 493           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 494          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 495 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 496 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 497       else
 498          ecorr=0.0d0
 499          ecorr5=0.0d0
 500          ecorr6=0.0d0
 501          eturn6=0.0d0
 502       endif
 503 !elwrite(iout,*) "in etotal",ipot
 504       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 505          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 506 !d         write (iout,*) "multibody_hb ecorr",ecorr
 507       endif
 508 !elwrite(iout,*) "afeter  multibody hb"
 509
 510 !      print *,"Processor",myrank," computed Ucorr"
 511 !
 512 ! If performing constraint dynamics, call the constraint energy
 513 !  after the equilibration time
 514       if(usampl.and.totT.gt.eq_time) then
 515 !elwrite(iout,*) "afeter  multibody hb"
 516          call EconstrQ
 517 !elwrite(iout,*) "afeter  multibody hb"
 518          call Econstr_back
 519 !elwrite(iout,*) "afeter  multibody hb"
 520       else
 521          Uconst=0.0d0
 522          Uconst_back=0.0d0
 523       endif
 524       call flush(iout)
 525 !         write(iout,*) "after Econstr"
 526
 527       if (wliptran.gt.0) then
 528 !        print *,"PRZED WYWOLANIEM"
 529         call Eliptransfer(eliptran)
 530       else
 531        eliptran=0.0d0
 532       endif
 533       if (fg_rank.eq.0) then
 534       if (AFMlog.gt.0) then
 535         call AFMforce(Eafmforce)
 536       else if (selfguide.gt.0) then
 537         call AFMvel(Eafmforce)
 538       endif
 539       endif
 540       if (tubemode.eq.1) then
 541        call calctube(etube)
 542       else if (tubemode.eq.2) then
 543        call calctube2(etube)
 544       elseif (tubemode.eq.3) then
 545        call calcnano(etube)
 546       else
 547        etube=0.0d0
 548       endif
 549 !--------------------------------------------------------
 550       call ebond_nucl(estr_nucl)
 551       call ebend_nucl(ebe_nucl)
 552       call etor_nucl(etors_nucl)
 553       call esb_gb(evdwsb,eelsb)
 554 !      call multibody_hb(ecorr,ecorr3,n_corr,n_corr1)
 555       call epp_nucl_sub(evdwpp,eespp)
 556       call epsb(evdwpsb,eelpsb)
 557
 558       print *,"after ebend", ebe_nucl
 559 #ifdef TIMING
 560       time_enecalc=time_enecalc+MPI_Wtime()-time00
 561 #endif
 562 !      print *,"Processor",myrank," computed Uconstr"
 563 #ifdef TIMING
 564       time00=MPI_Wtime()
 565 #endif
 566 !
 567 ! Sum the energies
 568 !
 569       energia(1)=evdw
 570 #ifdef SCP14
 571       energia(2)=evdw2-evdw2_14
 572       energia(18)=evdw2_14
 573 #else
 574       energia(2)=evdw2
 575       energia(18)=0.0d0
 576 #endif
 577 #ifdef SPLITELE
 578       energia(3)=ees
 579       energia(16)=evdw1
 580 #else
 581       energia(3)=ees+evdw1
 582       energia(16)=0.0d0
 583 #endif
 584       energia(4)=ecorr
 585       energia(5)=ecorr5
 586       energia(6)=ecorr6
 587       energia(7)=eel_loc
 588       energia(8)=eello_turn3
 589       energia(9)=eello_turn4
 590       energia(10)=eturn6
 591       energia(11)=ebe
 592       energia(12)=escloc
 593       energia(13)=etors
 594       energia(14)=etors_d
 595       energia(15)=ehpb
 596       energia(19)=edihcnstr
 597       energia(17)=estr
 598       energia(20)=Uconst+Uconst_back
 599       energia(21)=esccor
 600       energia(22)=eliptran
 601       energia(23)=Eafmforce
 602       energia(24)=ethetacnstr
 603       energia(25)=etube
 604 !---------------------------------------------------------------
 605       energia(26)=evdwpp
 606       energia(27)=eespp
 607       energia(28)=evdwpsb
 608       energia(29)=eelpsb
 609       energia(30)=evdwsb
 610       energia(31)=eelsb
 611       energia(32)=estr_nucl
 612       energia(33)=ebe_nucl
 613       energia(34)=esbloc
 614       energia(35)=etors_nucl
 615       energia(36)=etors_d_nucl
 616       energia(37)=ecorr_nucl
 617       energia(38)=ecorr3_nucl
 618 !----------------------------------------------------------------------
 619 !    Here are the energies showed per procesor if the are more processors
 620 !    per molecule then we sum it up in sum_energy subroutine
 621 !      print *," Processor",myrank," calls SUM_ENERGY"
 622       call sum_energy(energia,.true.)
 623       if (dyn_ss) call dyn_set_nss
 624 !      print *," Processor",myrank," left SUM_ENERGY"
 625 #ifdef TIMING
 626       time_sumene=time_sumene+MPI_Wtime()-time00
 627 #endif
 628 !el        call enerprint(energia)
 629 !elwrite(iout,*)"finish etotal"
 630       return
 631       end subroutine etotal
 632 !-----------------------------------------------------------------------------
 633       subroutine sum_energy(energia,reduce)
 634 !      implicit real*8 (a-h,o-z)
 635 !      include 'DIMENSIONS'
 636 #ifndef ISNAN
 637       external proc_proc
 638 #ifdef WINPGI
 639 !MS$ATTRIBUTES C ::  proc_proc
 640 #endif
 641 #endif
 642 #ifdef MPI
 643       include "mpif.h"
 644 #endif
 645 !      include 'COMMON.SETUP'
 646 !      include 'COMMON.IOUNITS'
 647       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 648 !      include 'COMMON.FFIELD'
 649 !      include 'COMMON.DERIV'
 650 !      include 'COMMON.INTERACT'
 651 !      include 'COMMON.SBRIDGE'
 652 !      include 'COMMON.CHAIN'
 653 !      include 'COMMON.VAR'
 654 !      include 'COMMON.CONTROL'
 655 !      include 'COMMON.TIME1'
 656       logical :: reduce
 657       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 658       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 659       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 660         eliptran,etube, Eafmforce,ethetacnstr
 661       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 662                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 663                       ecorr3_nucl
 664
 665       integer :: i
 666 #ifdef MPI
 667       integer :: ierr
 668       real(kind=8) :: time00
 669       if (nfgtasks.gt.1 .and. reduce) then
 670
 671 #ifdef DEBUG
 672         write (iout,*) "energies before REDUCE"
 673         call enerprint(energia)
 674         call flush(iout)
 675 #endif
 676         do i=0,n_ene
 677           enebuff(i)=energia(i)
 678         enddo
 679         time00=MPI_Wtime()
 680         call MPI_Barrier(FG_COMM,IERR)
 681         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 682         time00=MPI_Wtime()
 683         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 684           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 685 #ifdef DEBUG
 686         write (iout,*) "energies after REDUCE"
 687         call enerprint(energia)
 688         call flush(iout)
 689 #endif
 690         time_Reduce=time_Reduce+MPI_Wtime()-time00
 691       endif
 692       if (fg_rank.eq.0) then
 693 #endif
 694       evdw=energia(1)
 695 #ifdef SCP14
 696       evdw2=energia(2)+energia(18)
 697       evdw2_14=energia(18)
 698 #else
 699       evdw2=energia(2)
 700 #endif
 701 #ifdef SPLITELE
 702       ees=energia(3)
 703       evdw1=energia(16)
 704 #else
 705       ees=energia(3)
 706       evdw1=0.0d0
 707 #endif
 708       ecorr=energia(4)
 709       ecorr5=energia(5)
 710       ecorr6=energia(6)
 711       eel_loc=energia(7)
 712       eello_turn3=energia(8)
 713       eello_turn4=energia(9)
 714       eturn6=energia(10)
 715       ebe=energia(11)
 716       escloc=energia(12)
 717       etors=energia(13)
 718       etors_d=energia(14)
 719       ehpb=energia(15)
 720       edihcnstr=energia(19)
 721       estr=energia(17)
 722       Uconst=energia(20)
 723       esccor=energia(21)
 724       eliptran=energia(22)
 725       Eafmforce=energia(23)
 726       ethetacnstr=energia(24)
 727       etube=energia(25)
 728       evdwpp=energia(26)
 729       eespp=energia(27)
 730       evdwpsb=energia(28)
 731       eelpsb=energia(29)
 732       evdwsb=energia(30)
 733       eelsb=energia(31)
 734       estr_nucl=energia(32)
 735       ebe_nucl=energia(33)
 736       esbloc=energia(34)
 737       etors_nucl=energia(35)
 738       etors_d_nucl=energia(36)
 739       ecorr_nucl=energia(37)
 740       ecorr3_nucl=energia(38)
 741
 742
 743 #ifdef SPLITELE
 744       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 745        +wang*ebe+wtor*etors+wscloc*escloc &
 746        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 747        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 748        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 749        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 750        +Eafmforce+ethetacnstr  &
 751        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 752        +wvdwpp*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 753        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 754        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl
 755 #else
 756       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 757        +wang*ebe+wtor*etors+wscloc*escloc &
 758        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 759        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 760        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 761        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 762        +Eafmforce+ethetacnstr &
 763        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 764        +wvdwpp*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 765        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 766        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl
 767 #endif
 768       energia(0)=etot
 769 ! detecting NaNQ
 770 #ifdef ISNAN
 771 #ifdef AIX
 772       if (isnan(etot).ne.0) energia(0)=1.0d+99
 773 #else
 774       if (isnan(etot)) energia(0)=1.0d+99
 775 #endif
 776 #else
 777       i=0
 778 #ifdef WINPGI
 779       idumm=proc_proc(etot,i)
 780 #else
 781       call proc_proc(etot,i)
 782 #endif
 783       if(i.eq.1)energia(0)=1.0d+99
 784 #endif
 785 #ifdef MPI
 786       endif
 787 #endif
 788 !      call enerprint(energia)
 789       call flush(iout)
 790       return
 791       end subroutine sum_energy
 792 !-----------------------------------------------------------------------------
 793       subroutine rescale_weights(t_bath)
 794 !      implicit real*8 (a-h,o-z)
 795 #ifdef MPI
 796       include 'mpif.h'
 797 #endif
 798 !      include 'DIMENSIONS'
 799 !      include 'COMMON.IOUNITS'
 800 !      include 'COMMON.FFIELD'
 801 !      include 'COMMON.SBRIDGE'
 802       real(kind=8) :: kfac=2.4d0
 803       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 804 !el local variables
 805       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 806       real(kind=8) :: T0=3.0d2
 807       integer :: ierror
 808 !      facT=temp0/t_bath
 809 !      facT=2*temp0/(t_bath+temp0)
 810       if (rescale_mode.eq.0) then
 811         facT(1)=1.0d0
 812         facT(2)=1.0d0
 813         facT(3)=1.0d0
 814         facT(4)=1.0d0
 815         facT(5)=1.0d0
 816         facT(6)=1.0d0
 817       else if (rescale_mode.eq.1) then
 818         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 819         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 820         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 821         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 822         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 823 #ifdef WHAM_RUN
 824 !#if defined(WHAM_RUN) || defined(CLUSTER)
 825 #if defined(FUNCTH)
 826 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 827         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 828 #elif defined(FUNCT)
 829         facT(6)=t_bath/T0
 830 #else
 831         facT(6)=1.0d0
 832 #endif
 833 #endif
 834       else if (rescale_mode.eq.2) then
 835         x=t_bath/temp0
 836         x2=x*x
 837         x3=x2*x
 838         x4=x3*x
 839         x5=x4*x
 840         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 841         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 842         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 843         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 844         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 845 #ifdef WHAM_RUN
 846 !#if defined(WHAM_RUN) || defined(CLUSTER)
 847 #if defined(FUNCTH)
 848         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 849 #elif defined(FUNCT)
 850         facT(6)=t_bath/T0
 851 #else
 852         facT(6)=1.0d0
 853 #endif
 854 #endif
 855       else
 856         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 857         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 858 #ifdef MPI
 859        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 860 #endif
 861        stop 555
 862       endif
 863       welec=weights(3)*fact(1)
 864       wcorr=weights(4)*fact(3)
 865       wcorr5=weights(5)*fact(4)
 866       wcorr6=weights(6)*fact(5)
 867       wel_loc=weights(7)*fact(2)
 868       wturn3=weights(8)*fact(2)
 869       wturn4=weights(9)*fact(3)
 870       wturn6=weights(10)*fact(5)
 871       wtor=weights(13)*fact(1)
 872       wtor_d=weights(14)*fact(2)
 873       wsccor=weights(21)*fact(1)
 874
 875       return
 876       end subroutine rescale_weights
 877 !-----------------------------------------------------------------------------
 878       subroutine enerprint(energia)
 879 !      implicit real*8 (a-h,o-z)
 880 !      include 'DIMENSIONS'
 881 !      include 'COMMON.IOUNITS'
 882 !      include 'COMMON.FFIELD'
 883 !      include 'COMMON.SBRIDGE'
 884 !      include 'COMMON.MD'
 885       real(kind=8) :: energia(0:n_ene)
 886 !el local variables
 887       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 888       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 889       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
 890        etube,ethetacnstr,Eafmforce
 891       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 892                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 893                       ecorr3_nucl
 894
 895       etot=energia(0)
 896       evdw=energia(1)
 897       evdw2=energia(2)
 898 #ifdef SCP14
 899       evdw2=energia(2)+energia(18)
 900 #else
 901       evdw2=energia(2)
 902 #endif
 903       ees=energia(3)
 904 #ifdef SPLITELE
 905       evdw1=energia(16)
 906 #endif
 907       ecorr=energia(4)
 908       ecorr5=energia(5)
 909       ecorr6=energia(6)
 910       eel_loc=energia(7)
 911       eello_turn3=energia(8)
 912       eello_turn4=energia(9)
 913       eello_turn6=energia(10)
 914       ebe=energia(11)
 915       escloc=energia(12)
 916       etors=energia(13)
 917       etors_d=energia(14)
 918       ehpb=energia(15)
 919       edihcnstr=energia(19)
 920       estr=energia(17)
 921       Uconst=energia(20)
 922       esccor=energia(21)
 923       eliptran=energia(22)
 924       Eafmforce=energia(23)
 925       ethetacnstr=energia(24)
 926       etube=energia(25)
 927       evdwpp=energia(26)
 928       eespp=energia(27)
 929       evdwpsb=energia(28)
 930       eelpsb=energia(29)
 931       evdwsb=energia(30)
 932       eelsb=energia(31)
 933       estr_nucl=energia(32)
 934       ebe_nucl=energia(33)
 935       esbloc=energia(34)
 936       etors_nucl=energia(35)
 937       etors_d_nucl=energia(36)
 938       ecorr_nucl=energia(37)
 939       ecorr3_nucl=energia(38)
 940
 941 #ifdef SPLITELE
 942       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
 943         estr,wbond,ebe,wang,&
 944         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
 945         ecorr,wcorr,&
 946         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
 947         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
 948         edihcnstr,ethetacnstr,ebr*nss,&
 949         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
 950         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
 951         evdwpp,wvdwpp,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
 952         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
 953         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
 954         ecorr3_nucl,wcorr3_nucl, &
 955         etot
 956    10 format (/'Virtual-chain energies:'// &
 957        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
 958        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
 959        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
 960        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
 961        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
 962        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
 963        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
 964        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
 965        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
 966        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
 967        ' (SS bridges & dist. cnstr.)'/ &
 968        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 969        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 970        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
 971        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
 972        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
 973        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
 974        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
 975        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
 976        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
 977        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
 978        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
 979        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
 980        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
 981        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
 982        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
 983        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
 984        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
 985        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
 986        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
 987        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
 988        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
 989        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
 990        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
 991        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
 992        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
 993        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
 994        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
 995        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
 996        'ETOT=  ',1pE16.6,' (total)')
 997 #else
 998       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
 999         estr,wbond,ebe,wang,&
1000         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1001         ecorr,wcorr,&
1002         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1003         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1004         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
1005         etube,wtube, &
1006         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1007         evdwpp,wvdwpp,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1008         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1009         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1010         ecorr3_nucl,wcorr3_nucl, &
1011         etot
1012    10 format (/'Virtual-chain energies:'// &
1013        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1014        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1015        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1016        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1017        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1018        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1019        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1020        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1021        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1022        ' (SS bridges & dist. cnstr.)'/ &
1023        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1024        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1025        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1026        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1027        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1028        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1029        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1030        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1031        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1032        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1033        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1034        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1035        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1036        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1037        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1038        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1039        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1040        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1041        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1042        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1043        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1044        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1045        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1046        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1047        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1048        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1049        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1050        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1051        'ETOT=  ',1pE16.6,' (total)')
1052 #endif
1053       return
1054       end subroutine enerprint
1055 !-----------------------------------------------------------------------------
1056       subroutine elj(evdw)
1057 !
1058 ! This subroutine calculates the interaction energy of nonbonded side chains
1059 ! assuming the LJ potential of interaction.
1060 !
1061 !      implicit real*8 (a-h,o-z)
1062 !      include 'DIMENSIONS'
1063       real(kind=8),parameter :: accur=1.0d-10
1064 !      include 'COMMON.GEO'
1065 !      include 'COMMON.VAR'
1066 !      include 'COMMON.LOCAL'
1067 !      include 'COMMON.CHAIN'
1068 !      include 'COMMON.DERIV'
1069 !      include 'COMMON.INTERACT'
1070 !      include 'COMMON.TORSION'
1071 !      include 'COMMON.SBRIDGE'
1072 !      include 'COMMON.NAMES'
1073 !      include 'COMMON.IOUNITS'
1074 !      include 'COMMON.CONTACTS'
1075       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1076       integer :: num_conti
1077 !el local variables
1078       integer :: i,itypi,iint,j,itypi1,itypj,k
1079       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1080       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1081       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1082
1083 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1084       evdw=0.0D0
1085 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1086 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1087 !      allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres)
1088 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))       !(3,maxconts,maxres)
1089
1090       do i=iatsc_s,iatsc_e
1091         itypi=iabs(itype(i,1))
1092         if (itypi.eq.ntyp1) cycle
1093         itypi1=iabs(itype(i+1,1))
1094         xi=c(1,nres+i)
1095         yi=c(2,nres+i)
1096         zi=c(3,nres+i)
1097 ! Change 12/1/95
1098         num_conti=0
1099 !
1100 ! Calculate SC interaction energy.
1101 !
1102         do iint=1,nint_gr(i)
1103 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1104 !d   &                  'iend=',iend(i,iint)
1105           do j=istart(i,iint),iend(i,iint)
1106             itypj=iabs(itype(j,1))
1107             if (itypj.eq.ntyp1) cycle
1108             xj=c(1,nres+j)-xi
1109             yj=c(2,nres+j)-yi
1110             zj=c(3,nres+j)-zi
1111 ! Change 12/1/95 to calculate four-body interactions
1112             rij=xj*xj+yj*yj+zj*zj
1113             rrij=1.0D0/rij
1114 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1115             eps0ij=eps(itypi,itypj)
1116             fac=rrij**expon2
1117             e1=fac*fac*aa_aq(itypi,itypj)
1118             e2=fac*bb_aq(itypi,itypj)
1119             evdwij=e1+e2
1120 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1121 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1122 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1123 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1124 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1125 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1126             evdw=evdw+evdwij
1127 !
1128 ! Calculate the components of the gradient in DC and X
1129 !
1130             fac=-rrij*(e1+evdwij)
1131             gg(1)=xj*fac
1132             gg(2)=yj*fac
1133             gg(3)=zj*fac
1134             do k=1,3
1135               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1136               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1137               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1138               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1139             enddo
1140 !grad            do k=i,j-1
1141 !grad              do l=1,3
1142 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1143 !grad              enddo
1144 !grad            enddo
1145 !
1146 ! 12/1/95, revised on 5/20/97
1147 !
1148 ! Calculate the contact function. The ith column of the array JCONT will
1149 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1150 ! greater than I). The arrays FACONT and GACONT will contain the values of
1151 ! the contact function and its derivative.
1152 !
1153 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1154 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1155 ! Uncomment next line, if the correlation interactions are contact function only
1156             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1157               rij=dsqrt(rij)
1158               sigij=sigma(itypi,itypj)
1159               r0ij=rs0(itypi,itypj)
1160 !
1161 ! Check whether the SC's are not too far to make a contact.
1162 !
1163               rcut=1.5d0*r0ij
1164               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1165 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1166 !
1167               if (fcont.gt.0.0D0) then
1168 ! If the SC-SC distance if close to sigma, apply spline.
1169 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1170 !Adam &             fcont1,fprimcont1)
1171 !Adam           fcont1=1.0d0-fcont1
1172 !Adam           if (fcont1.gt.0.0d0) then
1173 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1174 !Adam             fcont=fcont*fcont1
1175 !Adam           endif
1176 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1177 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1178 !ga             do k=1,3
1179 !ga               gg(k)=gg(k)*eps0ij
1180 !ga             enddo
1181 !ga             eps0ij=-evdwij*eps0ij
1182 ! Uncomment for AL's type of SC correlation interactions.
1183 !adam           eps0ij=-evdwij
1184                 num_conti=num_conti+1
1185                 jcont(num_conti,i)=j
1186                 facont(num_conti,i)=fcont*eps0ij
1187                 fprimcont=eps0ij*fprimcont/rij
1188                 fcont=expon*fcont
1189 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1190 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1191 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1192 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1193                 gacont(1,num_conti,i)=-fprimcont*xj
1194                 gacont(2,num_conti,i)=-fprimcont*yj
1195                 gacont(3,num_conti,i)=-fprimcont*zj
1196 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1197 !d              write (iout,'(2i3,3f10.5)')
1198 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1199               endif
1200             endif
1201           enddo      ! j
1202         enddo        ! iint
1203 ! Change 12/1/95
1204         num_cont(i)=num_conti
1205       enddo          ! i
1206       do i=1,nct
1207         do j=1,3
1208           gvdwc(j,i)=expon*gvdwc(j,i)
1209           gvdwx(j,i)=expon*gvdwx(j,i)
1210         enddo
1211       enddo
1212 !******************************************************************************
1213 !
1214 !                              N O T E !!!
1215 !
1216 ! To save time, the factor of EXPON has been extracted from ALL components
1217 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1218 ! use!
1219 !
1220 !******************************************************************************
1221       return
1222       end subroutine elj
1223 !-----------------------------------------------------------------------------
1224       subroutine eljk(evdw)
1225 !
1226 ! This subroutine calculates the interaction energy of nonbonded side chains
1227 ! assuming the LJK potential of interaction.
1228 !
1229 !      implicit real*8 (a-h,o-z)
1230 !      include 'DIMENSIONS'
1231 !      include 'COMMON.GEO'
1232 !      include 'COMMON.VAR'
1233 !      include 'COMMON.LOCAL'
1234 !      include 'COMMON.CHAIN'
1235 !      include 'COMMON.DERIV'
1236 !      include 'COMMON.INTERACT'
1237 !      include 'COMMON.IOUNITS'
1238 !      include 'COMMON.NAMES'
1239       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1240       logical :: scheck
1241 !el local variables
1242       integer :: i,iint,j,itypi,itypi1,k,itypj
1243       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1244       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1245
1246 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1247       evdw=0.0D0
1248       do i=iatsc_s,iatsc_e
1249         itypi=iabs(itype(i,1))
1250         if (itypi.eq.ntyp1) cycle
1251         itypi1=iabs(itype(i+1,1))
1252         xi=c(1,nres+i)
1253         yi=c(2,nres+i)
1254         zi=c(3,nres+i)
1255 !
1256 ! Calculate SC interaction energy.
1257 !
1258         do iint=1,nint_gr(i)
1259           do j=istart(i,iint),iend(i,iint)
1260             itypj=iabs(itype(j,1))
1261             if (itypj.eq.ntyp1) cycle
1262             xj=c(1,nres+j)-xi
1263             yj=c(2,nres+j)-yi
1264             zj=c(3,nres+j)-zi
1265             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1266             fac_augm=rrij**expon
1267             e_augm=augm(itypi,itypj)*fac_augm
1268             r_inv_ij=dsqrt(rrij)
1269             rij=1.0D0/r_inv_ij
1270             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1271             fac=r_shift_inv**expon
1272             e1=fac*fac*aa_aq(itypi,itypj)
1273             e2=fac*bb_aq(itypi,itypj)
1274             evdwij=e_augm+e1+e2
1275 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1276 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1277 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1278 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1279 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1280 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1281 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1282             evdw=evdw+evdwij
1283 !
1284 ! Calculate the components of the gradient in DC and X
1285 !
1286             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1287             gg(1)=xj*fac
1288             gg(2)=yj*fac
1289             gg(3)=zj*fac
1290             do k=1,3
1291               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1292               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1293               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1294               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1295             enddo
1296 !grad            do k=i,j-1
1297 !grad              do l=1,3
1298 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1299 !grad              enddo
1300 !grad            enddo
1301           enddo      ! j
1302         enddo        ! iint
1303       enddo          ! i
1304       do i=1,nct
1305         do j=1,3
1306           gvdwc(j,i)=expon*gvdwc(j,i)
1307           gvdwx(j,i)=expon*gvdwx(j,i)
1308         enddo
1309       enddo
1310       return
1311       end subroutine eljk
1312 !-----------------------------------------------------------------------------
1313       subroutine ebp(evdw)
1314 !
1315 ! This subroutine calculates the interaction energy of nonbonded side chains
1316 ! assuming the Berne-Pechukas potential of interaction.
1317 !
1318       use comm_srutu
1319       use calc_data
1320 !      implicit real*8 (a-h,o-z)
1321 !      include 'DIMENSIONS'
1322 !      include 'COMMON.GEO'
1323 !      include 'COMMON.VAR'
1324 !      include 'COMMON.LOCAL'
1325 !      include 'COMMON.CHAIN'
1326 !      include 'COMMON.DERIV'
1327 !      include 'COMMON.NAMES'
1328 !      include 'COMMON.INTERACT'
1329 !      include 'COMMON.IOUNITS'
1330 !      include 'COMMON.CALC'
1331       use comm_srutu
1332 !el      integer :: icall
1333 !el      common /srutu/ icall
1334 !     double precision rrsave(maxdim)
1335       logical :: lprn
1336 !el local variables
1337       integer :: iint,itypi,itypi1,itypj
1338       real(kind=8) :: rrij,xi,yi,zi
1339       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1340
1341 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1342       evdw=0.0D0
1343 !     if (icall.eq.0) then
1344 !       lprn=.true.
1345 !     else
1346         lprn=.false.
1347 !     endif
1348 !el      ind=0
1349       do i=iatsc_s,iatsc_e
1350         itypi=iabs(itype(i,1))
1351         if (itypi.eq.ntyp1) cycle
1352         itypi1=iabs(itype(i+1,1))
1353         xi=c(1,nres+i)
1354         yi=c(2,nres+i)
1355         zi=c(3,nres+i)
1356         dxi=dc_norm(1,nres+i)
1357         dyi=dc_norm(2,nres+i)
1358         dzi=dc_norm(3,nres+i)
1359 !        dsci_inv=dsc_inv(itypi)
1360         dsci_inv=vbld_inv(i+nres)
1361 !
1362 ! Calculate SC interaction energy.
1363 !
1364         do iint=1,nint_gr(i)
1365           do j=istart(i,iint),iend(i,iint)
1366 !el            ind=ind+1
1367             itypj=iabs(itype(j,1))
1368             if (itypj.eq.ntyp1) cycle
1369 !            dscj_inv=dsc_inv(itypj)
1370             dscj_inv=vbld_inv(j+nres)
1371             chi1=chi(itypi,itypj)
1372             chi2=chi(itypj,itypi)
1373             chi12=chi1*chi2
1374             chip1=chip(itypi)
1375             chip2=chip(itypj)
1376             chip12=chip1*chip2
1377             alf1=alp(itypi)
1378             alf2=alp(itypj)
1379             alf12=0.5D0*(alf1+alf2)
1380 ! For diagnostics only!!!
1381 !           chi1=0.0D0
1382 !           chi2=0.0D0
1383 !           chi12=0.0D0
1384 !           chip1=0.0D0
1385 !           chip2=0.0D0
1386 !           chip12=0.0D0
1387 !           alf1=0.0D0
1388 !           alf2=0.0D0
1389 !           alf12=0.0D0
1390             xj=c(1,nres+j)-xi
1391             yj=c(2,nres+j)-yi
1392             zj=c(3,nres+j)-zi
1393             dxj=dc_norm(1,nres+j)
1394             dyj=dc_norm(2,nres+j)
1395             dzj=dc_norm(3,nres+j)
1396             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1397 !d          if (icall.eq.0) then
1398 !d            rrsave(ind)=rrij
1399 !d          else
1400 !d            rrij=rrsave(ind)
1401 !d          endif
1402             rij=dsqrt(rrij)
1403 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1404             call sc_angular
1405 ! Calculate whole angle-dependent part of epsilon and contributions
1406 ! to its derivatives
1407             fac=(rrij*sigsq)**expon2
1408             e1=fac*fac*aa_aq(itypi,itypj)
1409             e2=fac*bb_aq(itypi,itypj)
1410             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1411             eps2der=evdwij*eps3rt
1412             eps3der=evdwij*eps2rt
1413             evdwij=evdwij*eps2rt*eps3rt
1414             evdw=evdw+evdwij
1415             if (lprn) then
1416             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1417             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1418 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1419 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1420 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1421 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1422 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1423 !d     &        evdwij
1424             endif
1425 ! Calculate gradient components.
1426             e1=e1*eps1*eps2rt**2*eps3rt**2
1427             fac=-expon*(e1+evdwij)
1428             sigder=fac/sigsq
1429             fac=rrij*fac
1430 ! Calculate radial part of the gradient
1431             gg(1)=xj*fac
1432             gg(2)=yj*fac
1433             gg(3)=zj*fac
1434 ! Calculate the angular part of the gradient and sum add the contributions
1435 ! to the appropriate components of the Cartesian gradient.
1436             call sc_grad
1437           enddo      ! j
1438         enddo        ! iint
1439       enddo          ! i
1440 !     stop
1441       return
1442       end subroutine ebp
1443 !-----------------------------------------------------------------------------
1444       subroutine egb(evdw)
1445 !
1446 ! This subroutine calculates the interaction energy of nonbonded side chains
1447 ! assuming the Gay-Berne potential of interaction.
1448 !
1449       use calc_data
1450 !      implicit real*8 (a-h,o-z)
1451 !      include 'DIMENSIONS'
1452 !      include 'COMMON.GEO'
1453 !      include 'COMMON.VAR'
1454 !      include 'COMMON.LOCAL'
1455 !      include 'COMMON.CHAIN'
1456 !      include 'COMMON.DERIV'
1457 !      include 'COMMON.NAMES'
1458 !      include 'COMMON.INTERACT'
1459 !      include 'COMMON.IOUNITS'
1460 !      include 'COMMON.CALC'
1461 !      include 'COMMON.CONTROL'
1462 !      include 'COMMON.SBRIDGE'
1463       logical :: lprn
1464 !el local variables
1465       integer :: iint,itypi,itypi1,itypj,subchap
1466       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1467       real(kind=8) :: evdw,sig0ij
1468       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1469                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1470                     sslipi,sslipj,faclip
1471       integer :: ii
1472       real(kind=8) :: fracinbuf
1473
1474 !cccc      energy_dec=.false.
1475 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1476       evdw=0.0D0
1477       lprn=.false.
1478 !     if (icall.eq.0) lprn=.false.
1479 !el      ind=0
1480       do i=iatsc_s,iatsc_e
1481 !C        print *,"I am in EVDW",i
1482         itypi=iabs(itype(i,1))
1483 !        if (i.ne.47) cycle
1484         if (itypi.eq.ntyp1) cycle
1485         itypi1=iabs(itype(i+1,1))
1486         xi=c(1,nres+i)
1487         yi=c(2,nres+i)
1488         zi=c(3,nres+i)
1489           xi=dmod(xi,boxxsize)
1490           if (xi.lt.0) xi=xi+boxxsize
1491           yi=dmod(yi,boxysize)
1492           if (yi.lt.0) yi=yi+boxysize
1493           zi=dmod(zi,boxzsize)
1494           if (zi.lt.0) zi=zi+boxzsize
1495
1496        if ((zi.gt.bordlipbot)  &
1497         .and.(zi.lt.bordliptop)) then
1498 !C the energy transfer exist
1499         if (zi.lt.buflipbot) then
1500 !C what fraction I am in
1501          fracinbuf=1.0d0-  &
1502               ((zi-bordlipbot)/lipbufthick)
1503 !C lipbufthick is thickenes of lipid buffore
1504          sslipi=sscalelip(fracinbuf)
1505          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1506         elseif (zi.gt.bufliptop) then
1507          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1508          sslipi=sscalelip(fracinbuf)
1509          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1510         else
1511          sslipi=1.0d0
1512          ssgradlipi=0.0
1513         endif
1514        else
1515          sslipi=0.0d0
1516          ssgradlipi=0.0
1517        endif
1518 !       print *, sslipi,ssgradlipi
1519         dxi=dc_norm(1,nres+i)
1520         dyi=dc_norm(2,nres+i)
1521         dzi=dc_norm(3,nres+i)
1522 !        dsci_inv=dsc_inv(itypi)
1523         dsci_inv=vbld_inv(i+nres)
1524 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1525 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1526 !
1527 ! Calculate SC interaction energy.
1528 !
1529         do iint=1,nint_gr(i)
1530           do j=istart(i,iint),iend(i,iint)
1531             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1532               call dyn_ssbond_ene(i,j,evdwij)
1533               evdw=evdw+evdwij
1534               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1535                               'evdw',i,j,evdwij,' ss'
1536 !              if (energy_dec) write (iout,*) &
1537 !                              'evdw',i,j,evdwij,' ss'
1538              do k=j+1,iend(i,iint)
1539 !C search over all next residues
1540               if (dyn_ss_mask(k)) then
1541 !C check if they are cysteins
1542 !C              write(iout,*) 'k=',k
1543
1544 !c              write(iout,*) "PRZED TRI", evdwij
1545 !               evdwij_przed_tri=evdwij
1546               call triple_ssbond_ene(i,j,k,evdwij)
1547 !c               if(evdwij_przed_tri.ne.evdwij) then
1548 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1549 !c               endif
1550
1551 !c              write(iout,*) "PO TRI", evdwij
1552 !C call the energy function that removes the artifical triple disulfide
1553 !C bond the soubroutine is located in ssMD.F
1554               evdw=evdw+evdwij
1555               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1556                             'evdw',i,j,evdwij,'tss'
1557               endif!dyn_ss_mask(k)
1558              enddo! k
1559             ELSE
1560 !el            ind=ind+1
1561             itypj=iabs(itype(j,1))
1562             if (itypj.eq.ntyp1) cycle
1563 !             if (j.ne.78) cycle
1564 !            dscj_inv=dsc_inv(itypj)
1565             dscj_inv=vbld_inv(j+nres)
1566 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1567 !              1.0d0/vbld(j+nres) !d
1568 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1569             sig0ij=sigma(itypi,itypj)
1570             chi1=chi(itypi,itypj)
1571             chi2=chi(itypj,itypi)
1572             chi12=chi1*chi2
1573             chip1=chip(itypi)
1574             chip2=chip(itypj)
1575             chip12=chip1*chip2
1576             alf1=alp(itypi)
1577             alf2=alp(itypj)
1578             alf12=0.5D0*(alf1+alf2)
1579 ! For diagnostics only!!!
1580 !           chi1=0.0D0
1581 !           chi2=0.0D0
1582 !           chi12=0.0D0
1583 !           chip1=0.0D0
1584 !           chip2=0.0D0
1585 !           chip12=0.0D0
1586 !           alf1=0.0D0
1587 !           alf2=0.0D0
1588 !           alf12=0.0D0
1589            xj=c(1,nres+j)
1590            yj=c(2,nres+j)
1591            zj=c(3,nres+j)
1592           xj=dmod(xj,boxxsize)
1593           if (xj.lt.0) xj=xj+boxxsize
1594           yj=dmod(yj,boxysize)
1595           if (yj.lt.0) yj=yj+boxysize
1596           zj=dmod(zj,boxzsize)
1597           if (zj.lt.0) zj=zj+boxzsize
1598 !          print *,"tu",xi,yi,zi,xj,yj,zj
1599 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1600 ! this fragment set correct epsilon for lipid phase
1601        if ((zj.gt.bordlipbot)  &
1602        .and.(zj.lt.bordliptop)) then
1603 !C the energy transfer exist
1604         if (zj.lt.buflipbot) then
1605 !C what fraction I am in
1606          fracinbuf=1.0d0-     &
1607              ((zj-bordlipbot)/lipbufthick)
1608 !C lipbufthick is thickenes of lipid buffore
1609          sslipj=sscalelip(fracinbuf)
1610          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1611         elseif (zj.gt.bufliptop) then
1612          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1613          sslipj=sscalelip(fracinbuf)
1614          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1615         else
1616          sslipj=1.0d0
1617          ssgradlipj=0.0
1618         endif
1619        else
1620          sslipj=0.0d0
1621          ssgradlipj=0.0
1622        endif
1623       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1624        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1625       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1626        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1627 !------------------------------------------------
1628       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1629       xj_safe=xj
1630       yj_safe=yj
1631       zj_safe=zj
1632       subchap=0
1633       do xshift=-1,1
1634       do yshift=-1,1
1635       do zshift=-1,1
1636           xj=xj_safe+xshift*boxxsize
1637           yj=yj_safe+yshift*boxysize
1638           zj=zj_safe+zshift*boxzsize
1639           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1640           if(dist_temp.lt.dist_init) then
1641             dist_init=dist_temp
1642             xj_temp=xj
1643             yj_temp=yj
1644             zj_temp=zj
1645             subchap=1
1646           endif
1647        enddo
1648        enddo
1649        enddo
1650        if (subchap.eq.1) then
1651           xj=xj_temp-xi
1652           yj=yj_temp-yi
1653           zj=zj_temp-zi
1654        else
1655           xj=xj_safe-xi
1656           yj=yj_safe-yi
1657           zj=zj_safe-zi
1658        endif
1659             dxj=dc_norm(1,nres+j)
1660             dyj=dc_norm(2,nres+j)
1661             dzj=dc_norm(3,nres+j)
1662 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1663 !            write (iout,*) "j",j," dc_norm",& !d
1664 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1665 !          write(iout,*)"rrij ",rrij
1666 !          write(iout,*)"xj yj zj ", xj, yj, zj
1667 !          write(iout,*)"xi yi zi ", xi, yi, zi
1668 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1669             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1670             rij=dsqrt(rrij)
1671             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1672             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1673 !            print *,sss_ele_cut,sss_ele_grad,&
1674 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1675             if (sss_ele_cut.le.0.0) cycle
1676 ! Calculate angle-dependent terms of energy and contributions to their
1677 ! derivatives.
1678             call sc_angular
1679             sigsq=1.0D0/sigsq
1680             sig=sig0ij*dsqrt(sigsq)
1681             rij_shift=1.0D0/rij-sig+sig0ij
1682 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1683 !            "sig0ij",sig0ij
1684 ! for diagnostics; uncomment
1685 !            rij_shift=1.2*sig0ij
1686 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1687             if (rij_shift.le.0.0D0) then
1688               evdw=1.0D20
1689 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1690 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1691 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1692               return
1693             endif
1694             sigder=-sig*sigsq
1695 !---------------------------------------------------------------
1696             rij_shift=1.0D0/rij_shift
1697             fac=rij_shift**expon
1698             faclip=fac
1699             e1=fac*fac*aa!(itypi,itypj)
1700             e2=fac*bb!(itypi,itypj)
1701             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1702             eps2der=evdwij*eps3rt
1703             eps3der=evdwij*eps2rt
1704 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1705 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1706 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1707             evdwij=evdwij*eps2rt*eps3rt
1708             evdw=evdw+evdwij*sss_ele_cut
1709             if (lprn) then
1710             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1711             epsi=bb**2/aa!(itypi,itypj)
1712             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1713               restyp(itypi,1),i,restyp(itypj,1),j, &
1714               epsi,sigm,chi1,chi2,chip1,chip2, &
1715               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1716               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1717               evdwij
1718             endif
1719
1720             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1721                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1722 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1723 !            if (energy_dec) write (iout,*) &
1724 !                             'evdw',i,j,evdwij
1725 !                       print *,"ZALAMKA", evdw
1726
1727 ! Calculate gradient components.
1728             e1=e1*eps1*eps2rt**2*eps3rt**2
1729             fac=-expon*(e1+evdwij)*rij_shift
1730             sigder=fac*sigder
1731             fac=rij*fac
1732 !            print *,'before fac',fac,rij,evdwij
1733             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1734             /sigma(itypi,itypj)*rij
1735 !            print *,'grad part scale',fac,   &
1736 !             evdwij*sss_ele_grad/sss_ele_cut &
1737 !            /sigma(itypi,itypj)*rij
1738 !            fac=0.0d0
1739 ! Calculate the radial part of the gradient
1740             gg(1)=xj*fac
1741             gg(2)=yj*fac
1742             gg(3)=zj*fac
1743 !C Calculate the radial part of the gradient
1744             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1745        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1746         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1747        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1748             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1749             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1750
1751 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1752 ! Calculate angular part of the gradient.
1753             call sc_grad
1754             ENDIF    ! dyn_ss
1755           enddo      ! j
1756         enddo        ! iint
1757       enddo          ! i
1758 !       print *,"ZALAMKA", evdw
1759 !      write (iout,*) "Number of loop steps in EGB:",ind
1760 !ccc      energy_dec=.false.
1761       return
1762       end subroutine egb
1763 !-----------------------------------------------------------------------------
1764       subroutine egbv(evdw)
1765 !
1766 ! This subroutine calculates the interaction energy of nonbonded side chains
1767 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1768 !
1769       use comm_srutu
1770       use calc_data
1771 !      implicit real*8 (a-h,o-z)
1772 !      include 'DIMENSIONS'
1773 !      include 'COMMON.GEO'
1774 !      include 'COMMON.VAR'
1775 !      include 'COMMON.LOCAL'
1776 !      include 'COMMON.CHAIN'
1777 !      include 'COMMON.DERIV'
1778 !      include 'COMMON.NAMES'
1779 !      include 'COMMON.INTERACT'
1780 !      include 'COMMON.IOUNITS'
1781 !      include 'COMMON.CALC'
1782       use comm_srutu
1783 !el      integer :: icall
1784 !el      common /srutu/ icall
1785       logical :: lprn
1786 !el local variables
1787       integer :: iint,itypi,itypi1,itypj
1788       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1789       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1790
1791 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1792       evdw=0.0D0
1793       lprn=.false.
1794 !     if (icall.eq.0) lprn=.true.
1795 !el      ind=0
1796       do i=iatsc_s,iatsc_e
1797         itypi=iabs(itype(i,1))
1798         if (itypi.eq.ntyp1) cycle
1799         itypi1=iabs(itype(i+1,1))
1800         xi=c(1,nres+i)
1801         yi=c(2,nres+i)
1802         zi=c(3,nres+i)
1803         dxi=dc_norm(1,nres+i)
1804         dyi=dc_norm(2,nres+i)
1805         dzi=dc_norm(3,nres+i)
1806 !        dsci_inv=dsc_inv(itypi)
1807         dsci_inv=vbld_inv(i+nres)
1808 !
1809 ! Calculate SC interaction energy.
1810 !
1811         do iint=1,nint_gr(i)
1812           do j=istart(i,iint),iend(i,iint)
1813 !el            ind=ind+1
1814             itypj=iabs(itype(j,1))
1815             if (itypj.eq.ntyp1) cycle
1816 !            dscj_inv=dsc_inv(itypj)
1817             dscj_inv=vbld_inv(j+nres)
1818             sig0ij=sigma(itypi,itypj)
1819             r0ij=r0(itypi,itypj)
1820             chi1=chi(itypi,itypj)
1821             chi2=chi(itypj,itypi)
1822             chi12=chi1*chi2
1823             chip1=chip(itypi)
1824             chip2=chip(itypj)
1825             chip12=chip1*chip2
1826             alf1=alp(itypi)
1827             alf2=alp(itypj)
1828             alf12=0.5D0*(alf1+alf2)
1829 ! For diagnostics only!!!
1830 !           chi1=0.0D0
1831 !           chi2=0.0D0
1832 !           chi12=0.0D0
1833 !           chip1=0.0D0
1834 !           chip2=0.0D0
1835 !           chip12=0.0D0
1836 !           alf1=0.0D0
1837 !           alf2=0.0D0
1838 !           alf12=0.0D0
1839             xj=c(1,nres+j)-xi
1840             yj=c(2,nres+j)-yi
1841             zj=c(3,nres+j)-zi
1842             dxj=dc_norm(1,nres+j)
1843             dyj=dc_norm(2,nres+j)
1844             dzj=dc_norm(3,nres+j)
1845             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1846             rij=dsqrt(rrij)
1847 ! Calculate angle-dependent terms of energy and contributions to their
1848 ! derivatives.
1849             call sc_angular
1850             sigsq=1.0D0/sigsq
1851             sig=sig0ij*dsqrt(sigsq)
1852             rij_shift=1.0D0/rij-sig+r0ij
1853 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1854             if (rij_shift.le.0.0D0) then
1855               evdw=1.0D20
1856               return
1857             endif
1858             sigder=-sig*sigsq
1859 !---------------------------------------------------------------
1860             rij_shift=1.0D0/rij_shift
1861             fac=rij_shift**expon
1862             e1=fac*fac*aa_aq(itypi,itypj)
1863             e2=fac*bb_aq(itypi,itypj)
1864             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1865             eps2der=evdwij*eps3rt
1866             eps3der=evdwij*eps2rt
1867             fac_augm=rrij**expon
1868             e_augm=augm(itypi,itypj)*fac_augm
1869             evdwij=evdwij*eps2rt*eps3rt
1870             evdw=evdw+evdwij+e_augm
1871             if (lprn) then
1872             sigm=dabs(aa_aq(itypi,itypj)/&
1873             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1874             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1875             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1876               restyp(itypi,1),i,restyp(itypj,1),j,&
1877               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1878               chi1,chi2,chip1,chip2,&
1879               eps1,eps2rt**2,eps3rt**2,&
1880               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1881               evdwij+e_augm
1882             endif
1883 ! Calculate gradient components.
1884             e1=e1*eps1*eps2rt**2*eps3rt**2
1885             fac=-expon*(e1+evdwij)*rij_shift
1886             sigder=fac*sigder
1887             fac=rij*fac-2*expon*rrij*e_augm
1888 ! Calculate the radial part of the gradient
1889             gg(1)=xj*fac
1890             gg(2)=yj*fac
1891             gg(3)=zj*fac
1892 ! Calculate angular part of the gradient.
1893             call sc_grad
1894           enddo      ! j
1895         enddo        ! iint
1896       enddo          ! i
1897       end subroutine egbv
1898 !-----------------------------------------------------------------------------
1899 !el      subroutine sc_angular in module geometry
1900 !-----------------------------------------------------------------------------
1901       subroutine e_softsphere(evdw)
1902 !
1903 ! This subroutine calculates the interaction energy of nonbonded side chains
1904 ! assuming the LJ potential of interaction.
1905 !
1906 !      implicit real*8 (a-h,o-z)
1907 !      include 'DIMENSIONS'
1908       real(kind=8),parameter :: accur=1.0d-10
1909 !      include 'COMMON.GEO'
1910 !      include 'COMMON.VAR'
1911 !      include 'COMMON.LOCAL'
1912 !      include 'COMMON.CHAIN'
1913 !      include 'COMMON.DERIV'
1914 !      include 'COMMON.INTERACT'
1915 !      include 'COMMON.TORSION'
1916 !      include 'COMMON.SBRIDGE'
1917 !      include 'COMMON.NAMES'
1918 !      include 'COMMON.IOUNITS'
1919 !      include 'COMMON.CONTACTS'
1920       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1921 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1922 !el local variables
1923       integer :: i,iint,j,itypi,itypi1,itypj,k
1924       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
1925       real(kind=8) :: fac
1926
1927       evdw=0.0D0
1928       do i=iatsc_s,iatsc_e
1929         itypi=iabs(itype(i,1))
1930         if (itypi.eq.ntyp1) cycle
1931         itypi1=iabs(itype(i+1,1))
1932         xi=c(1,nres+i)
1933         yi=c(2,nres+i)
1934         zi=c(3,nres+i)
1935 !
1936 ! Calculate SC interaction energy.
1937 !
1938         do iint=1,nint_gr(i)
1939 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1940 !d   &                  'iend=',iend(i,iint)
1941           do j=istart(i,iint),iend(i,iint)
1942             itypj=iabs(itype(j,1))
1943             if (itypj.eq.ntyp1) cycle
1944             xj=c(1,nres+j)-xi
1945             yj=c(2,nres+j)-yi
1946             zj=c(3,nres+j)-zi
1947             rij=xj*xj+yj*yj+zj*zj
1948 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1949             r0ij=r0(itypi,itypj)
1950             r0ijsq=r0ij*r0ij
1951 !            print *,i,j,r0ij,dsqrt(rij)
1952             if (rij.lt.r0ijsq) then
1953               evdwij=0.25d0*(rij-r0ijsq)**2
1954               fac=rij-r0ijsq
1955             else
1956               evdwij=0.0d0
1957               fac=0.0d0
1958             endif
1959             evdw=evdw+evdwij
1960 !
1961 ! Calculate the components of the gradient in DC and X
1962 !
1963             gg(1)=xj*fac
1964             gg(2)=yj*fac
1965             gg(3)=zj*fac
1966             do k=1,3
1967               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1968               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1969               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1970               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1971             enddo
1972 !grad            do k=i,j-1
1973 !grad              do l=1,3
1974 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1975 !grad              enddo
1976 !grad            enddo
1977           enddo ! j
1978         enddo ! iint
1979       enddo ! i
1980       return
1981       end subroutine e_softsphere
1982 !-----------------------------------------------------------------------------
1983       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1984 !
1985 ! Soft-sphere potential of p-p interaction
1986 !
1987 !      implicit real*8 (a-h,o-z)
1988 !      include 'DIMENSIONS'
1989 !      include 'COMMON.CONTROL'
1990 !      include 'COMMON.IOUNITS'
1991 !      include 'COMMON.GEO'
1992 !      include 'COMMON.VAR'
1993 !      include 'COMMON.LOCAL'
1994 !      include 'COMMON.CHAIN'
1995 !      include 'COMMON.DERIV'
1996 !      include 'COMMON.INTERACT'
1997 !      include 'COMMON.CONTACTS'
1998 !      include 'COMMON.TORSION'
1999 !      include 'COMMON.VECTORS'
2000 !      include 'COMMON.FFIELD'
2001       real(kind=8),dimension(3) :: ggg
2002 !d      write(iout,*) 'In EELEC_soft_sphere'
2003 !el local variables
2004       integer :: i,j,k,num_conti,iteli,itelj
2005       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2006       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2007       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2008
2009       ees=0.0D0
2010       evdw1=0.0D0
2011       eel_loc=0.0d0
2012       eello_turn3=0.0d0
2013       eello_turn4=0.0d0
2014 !el      ind=0
2015       do i=iatel_s,iatel_e
2016         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2017         dxi=dc(1,i)
2018         dyi=dc(2,i)
2019         dzi=dc(3,i)
2020         xmedi=c(1,i)+0.5d0*dxi
2021         ymedi=c(2,i)+0.5d0*dyi
2022         zmedi=c(3,i)+0.5d0*dzi
2023         num_conti=0
2024 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2025         do j=ielstart(i),ielend(i)
2026           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2027 !el          ind=ind+1
2028           iteli=itel(i)
2029           itelj=itel(j)
2030           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2031           r0ij=rpp(iteli,itelj)
2032           r0ijsq=r0ij*r0ij
2033           dxj=dc(1,j)
2034           dyj=dc(2,j)
2035           dzj=dc(3,j)
2036           xj=c(1,j)+0.5D0*dxj-xmedi
2037           yj=c(2,j)+0.5D0*dyj-ymedi
2038           zj=c(3,j)+0.5D0*dzj-zmedi
2039           rij=xj*xj+yj*yj+zj*zj
2040           if (rij.lt.r0ijsq) then
2041             evdw1ij=0.25d0*(rij-r0ijsq)**2
2042             fac=rij-r0ijsq
2043           else
2044             evdw1ij=0.0d0
2045             fac=0.0d0
2046           endif
2047           evdw1=evdw1+evdw1ij
2048 !
2049 ! Calculate contributions to the Cartesian gradient.
2050 !
2051           ggg(1)=fac*xj
2052           ggg(2)=fac*yj
2053           ggg(3)=fac*zj
2054           do k=1,3
2055             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2056             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2057           enddo
2058 !
2059 ! Loop over residues i+1 thru j-1.
2060 !
2061 !grad          do k=i+1,j-1
2062 !grad            do l=1,3
2063 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2064 !grad            enddo
2065 !grad          enddo
2066         enddo ! j
2067       enddo   ! i
2068 !grad      do i=nnt,nct-1
2069 !grad        do k=1,3
2070 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2071 !grad        enddo
2072 !grad        do j=i+1,nct-1
2073 !grad          do k=1,3
2074 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2075 !grad          enddo
2076 !grad        enddo
2077 !grad      enddo
2078       return
2079       end subroutine eelec_soft_sphere
2080 !-----------------------------------------------------------------------------
2081       subroutine vec_and_deriv
2082 !      implicit real*8 (a-h,o-z)
2083 !      include 'DIMENSIONS'
2084 #ifdef MPI
2085       include 'mpif.h'
2086 #endif
2087 !      include 'COMMON.IOUNITS'
2088 !      include 'COMMON.GEO'
2089 !      include 'COMMON.VAR'
2090 !      include 'COMMON.LOCAL'
2091 !      include 'COMMON.CHAIN'
2092 !      include 'COMMON.VECTORS'
2093 !      include 'COMMON.SETUP'
2094 !      include 'COMMON.TIME1'
2095       real(kind=8),dimension(3,3,2) :: uyder,uzder
2096       real(kind=8),dimension(2) :: vbld_inv_temp
2097 ! Compute the local reference systems. For reference system (i), the
2098 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2099 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2100 !el local variables
2101       integer :: i,j,k,l
2102       real(kind=8) :: facy,fac,costh
2103
2104 #ifdef PARVEC
2105       do i=ivec_start,ivec_end
2106 #else
2107       do i=1,nres-1
2108 #endif
2109           if (i.eq.nres-1) then
2110 ! Case of the last full residue
2111 ! Compute the Z-axis
2112             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2113             costh=dcos(pi-theta(nres))
2114             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2115             do k=1,3
2116               uz(k,i)=fac*uz(k,i)
2117             enddo
2118 ! Compute the derivatives of uz
2119             uzder(1,1,1)= 0.0d0
2120             uzder(2,1,1)=-dc_norm(3,i-1)
2121             uzder(3,1,1)= dc_norm(2,i-1)
2122             uzder(1,2,1)= dc_norm(3,i-1)
2123             uzder(2,2,1)= 0.0d0
2124             uzder(3,2,1)=-dc_norm(1,i-1)
2125             uzder(1,3,1)=-dc_norm(2,i-1)
2126             uzder(2,3,1)= dc_norm(1,i-1)
2127             uzder(3,3,1)= 0.0d0
2128             uzder(1,1,2)= 0.0d0
2129             uzder(2,1,2)= dc_norm(3,i)
2130             uzder(3,1,2)=-dc_norm(2,i)
2131             uzder(1,2,2)=-dc_norm(3,i)
2132             uzder(2,2,2)= 0.0d0
2133             uzder(3,2,2)= dc_norm(1,i)
2134             uzder(1,3,2)= dc_norm(2,i)
2135             uzder(2,3,2)=-dc_norm(1,i)
2136             uzder(3,3,2)= 0.0d0
2137 ! Compute the Y-axis
2138             facy=fac
2139             do k=1,3
2140               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2141             enddo
2142 ! Compute the derivatives of uy
2143             do j=1,3
2144               do k=1,3
2145                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2146                               -dc_norm(k,i)*dc_norm(j,i-1)
2147                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2148               enddo
2149               uyder(j,j,1)=uyder(j,j,1)-costh
2150               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2151             enddo
2152             do j=1,2
2153               do k=1,3
2154                 do l=1,3
2155                   uygrad(l,k,j,i)=uyder(l,k,j)
2156                   uzgrad(l,k,j,i)=uzder(l,k,j)
2157                 enddo
2158               enddo
2159             enddo
2160             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2161             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2162             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2163             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2164           else
2165 ! Other residues
2166 ! Compute the Z-axis
2167             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2168             costh=dcos(pi-theta(i+2))
2169             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2170             do k=1,3
2171               uz(k,i)=fac*uz(k,i)
2172             enddo
2173 ! Compute the derivatives of uz
2174             uzder(1,1,1)= 0.0d0
2175             uzder(2,1,1)=-dc_norm(3,i+1)
2176             uzder(3,1,1)= dc_norm(2,i+1)
2177             uzder(1,2,1)= dc_norm(3,i+1)
2178             uzder(2,2,1)= 0.0d0
2179             uzder(3,2,1)=-dc_norm(1,i+1)
2180             uzder(1,3,1)=-dc_norm(2,i+1)
2181             uzder(2,3,1)= dc_norm(1,i+1)
2182             uzder(3,3,1)= 0.0d0
2183             uzder(1,1,2)= 0.0d0
2184             uzder(2,1,2)= dc_norm(3,i)
2185             uzder(3,1,2)=-dc_norm(2,i)
2186             uzder(1,2,2)=-dc_norm(3,i)
2187             uzder(2,2,2)= 0.0d0
2188             uzder(3,2,2)= dc_norm(1,i)
2189             uzder(1,3,2)= dc_norm(2,i)
2190             uzder(2,3,2)=-dc_norm(1,i)
2191             uzder(3,3,2)= 0.0d0
2192 ! Compute the Y-axis
2193             facy=fac
2194             do k=1,3
2195               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2196             enddo
2197 ! Compute the derivatives of uy
2198             do j=1,3
2199               do k=1,3
2200                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2201                               -dc_norm(k,i)*dc_norm(j,i+1)
2202                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2203               enddo
2204               uyder(j,j,1)=uyder(j,j,1)-costh
2205               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2206             enddo
2207             do j=1,2
2208               do k=1,3
2209                 do l=1,3
2210                   uygrad(l,k,j,i)=uyder(l,k,j)
2211                   uzgrad(l,k,j,i)=uzder(l,k,j)
2212                 enddo
2213               enddo
2214             enddo
2215             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2216             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2217             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2218             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2219           endif
2220       enddo
2221       do i=1,nres-1
2222         vbld_inv_temp(1)=vbld_inv(i+1)
2223         if (i.lt.nres-1) then
2224           vbld_inv_temp(2)=vbld_inv(i+2)
2225           else
2226           vbld_inv_temp(2)=vbld_inv(i)
2227           endif
2228         do j=1,2
2229           do k=1,3
2230             do l=1,3
2231               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2232               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2233             enddo
2234           enddo
2235         enddo
2236       enddo
2237 #if defined(PARVEC) && defined(MPI)
2238       if (nfgtasks1.gt.1) then
2239         time00=MPI_Wtime()
2240 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2241 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2242 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2243         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2244          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2245          FG_COMM1,IERR)
2246         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2247          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2248          FG_COMM1,IERR)
2249         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2250          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2251          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2252         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2253          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2254          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2255         time_gather=time_gather+MPI_Wtime()-time00
2256       endif
2257 !      if (fg_rank.eq.0) then
2258 !        write (iout,*) "Arrays UY and UZ"
2259 !        do i=1,nres-1
2260 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2261 !     &     (uz(k,i),k=1,3)
2262 !        enddo
2263 !      endif
2264 #endif
2265       return
2266       end subroutine vec_and_deriv
2267 !-----------------------------------------------------------------------------
2268       subroutine check_vecgrad
2269 !      implicit real*8 (a-h,o-z)
2270 !      include 'DIMENSIONS'
2271 !      include 'COMMON.IOUNITS'
2272 !      include 'COMMON.GEO'
2273 !      include 'COMMON.VAR'
2274 !      include 'COMMON.LOCAL'
2275 !      include 'COMMON.CHAIN'
2276 !      include 'COMMON.VECTORS'
2277       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt     !(3,3,2,maxres)
2278       real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
2279       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2280       real(kind=8),dimension(3) :: erij
2281       real(kind=8) :: delta=1.0d-7
2282 !el local variables
2283       integer :: i,j,k,l
2284
2285       call vec_and_deriv
2286 !d      do i=1,nres
2287 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2288 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2289 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2290 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2291 !d     &     (dc_norm(if90,i),if90=1,3)
2292 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2293 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2294 !d          write(iout,'(a)')
2295 !d      enddo
2296       do i=1,nres
2297         do j=1,2
2298           do k=1,3
2299             do l=1,3
2300               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2301               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2302             enddo
2303           enddo
2304         enddo
2305       enddo
2306       call vec_and_deriv
2307       do i=1,nres
2308         do j=1,3
2309           uyt(j,i)=uy(j,i)
2310           uzt(j,i)=uz(j,i)
2311         enddo
2312       enddo
2313       do i=1,nres
2314 !d        write (iout,*) 'i=',i
2315         do k=1,3
2316           erij(k)=dc_norm(k,i)
2317         enddo
2318         do j=1,3
2319           do k=1,3
2320             dc_norm(k,i)=erij(k)
2321           enddo
2322           dc_norm(j,i)=dc_norm(j,i)+delta
2323 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2324 !          do k=1,3
2325 !            dc_norm(k,i)=dc_norm(k,i)/fac
2326 !          enddo
2327 !          write (iout,*) (dc_norm(k,i),k=1,3)
2328 !          write (iout,*) (erij(k),k=1,3)
2329           call vec_and_deriv
2330           do k=1,3
2331             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2332             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2333             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2334             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2335           enddo
2336 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2337 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2338 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2339         enddo
2340         do k=1,3
2341           dc_norm(k,i)=erij(k)
2342         enddo
2343 !d        do k=1,3
2344 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2345 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2346 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2347 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2348 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2349 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2350 !d          write (iout,'(a)')
2351 !d        enddo
2352       enddo
2353       return
2354       end subroutine check_vecgrad
2355 !-----------------------------------------------------------------------------
2356       subroutine set_matrices
2357 !      implicit real*8 (a-h,o-z)
2358 !      include 'DIMENSIONS'
2359 #ifdef MPI
2360       include "mpif.h"
2361 !      include "COMMON.SETUP"
2362       integer :: IERR
2363       integer :: status(MPI_STATUS_SIZE)
2364 #endif
2365 !      include 'COMMON.IOUNITS'
2366 !      include 'COMMON.GEO'
2367 !      include 'COMMON.VAR'
2368 !      include 'COMMON.LOCAL'
2369 !      include 'COMMON.CHAIN'
2370 !      include 'COMMON.DERIV'
2371 !      include 'COMMON.INTERACT'
2372 !      include 'COMMON.CONTACTS'
2373 !      include 'COMMON.TORSION'
2374 !      include 'COMMON.VECTORS'
2375 !      include 'COMMON.FFIELD'
2376       real(kind=8) :: auxvec(2),auxmat(2,2)
2377       integer :: i,iti1,iti,k,l
2378       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2379 !       print *,"in set matrices"
2380 !
2381 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2382 ! to calculate the el-loc multibody terms of various order.
2383 !
2384 !AL el      mu=0.0d0
2385 #ifdef PARMAT
2386       do i=ivec_start+2,ivec_end+2
2387 #else
2388       do i=3,nres+1
2389 #endif
2390 !      print *,i,"i"
2391         if (i .lt. nres+1) then
2392           sin1=dsin(phi(i))
2393           cos1=dcos(phi(i))
2394           sintab(i-2)=sin1
2395           costab(i-2)=cos1
2396           obrot(1,i-2)=cos1
2397           obrot(2,i-2)=sin1
2398           sin2=dsin(2*phi(i))
2399           cos2=dcos(2*phi(i))
2400           sintab2(i-2)=sin2
2401           costab2(i-2)=cos2
2402           obrot2(1,i-2)=cos2
2403           obrot2(2,i-2)=sin2
2404           Ug(1,1,i-2)=-cos1
2405           Ug(1,2,i-2)=-sin1
2406           Ug(2,1,i-2)=-sin1
2407           Ug(2,2,i-2)= cos1
2408           Ug2(1,1,i-2)=-cos2
2409           Ug2(1,2,i-2)=-sin2
2410           Ug2(2,1,i-2)=-sin2
2411           Ug2(2,2,i-2)= cos2
2412         else
2413           costab(i-2)=1.0d0
2414           sintab(i-2)=0.0d0
2415           obrot(1,i-2)=1.0d0
2416           obrot(2,i-2)=0.0d0
2417           obrot2(1,i-2)=0.0d0
2418           obrot2(2,i-2)=0.0d0
2419           Ug(1,1,i-2)=1.0d0
2420           Ug(1,2,i-2)=0.0d0
2421           Ug(2,1,i-2)=0.0d0
2422           Ug(2,2,i-2)=1.0d0
2423           Ug2(1,1,i-2)=0.0d0
2424           Ug2(1,2,i-2)=0.0d0
2425           Ug2(2,1,i-2)=0.0d0
2426           Ug2(2,2,i-2)=0.0d0
2427         endif
2428         if (i .gt. 3 .and. i .lt. nres+1) then
2429           obrot_der(1,i-2)=-sin1
2430           obrot_der(2,i-2)= cos1
2431           Ugder(1,1,i-2)= sin1
2432           Ugder(1,2,i-2)=-cos1
2433           Ugder(2,1,i-2)=-cos1
2434           Ugder(2,2,i-2)=-sin1
2435           dwacos2=cos2+cos2
2436           dwasin2=sin2+sin2
2437           obrot2_der(1,i-2)=-dwasin2
2438           obrot2_der(2,i-2)= dwacos2
2439           Ug2der(1,1,i-2)= dwasin2
2440           Ug2der(1,2,i-2)=-dwacos2
2441           Ug2der(2,1,i-2)=-dwacos2
2442           Ug2der(2,2,i-2)=-dwasin2
2443         else
2444           obrot_der(1,i-2)=0.0d0
2445           obrot_der(2,i-2)=0.0d0
2446           Ugder(1,1,i-2)=0.0d0
2447           Ugder(1,2,i-2)=0.0d0
2448           Ugder(2,1,i-2)=0.0d0
2449           Ugder(2,2,i-2)=0.0d0
2450           obrot2_der(1,i-2)=0.0d0
2451           obrot2_der(2,i-2)=0.0d0
2452           Ug2der(1,1,i-2)=0.0d0
2453           Ug2der(1,2,i-2)=0.0d0
2454           Ug2der(2,1,i-2)=0.0d0
2455           Ug2der(2,2,i-2)=0.0d0
2456         endif
2457 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2458         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2459           iti = itortyp(itype(i-2,1))
2460         else
2461           iti=ntortyp+1
2462         endif
2463 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2464         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2465           iti1 = itortyp(itype(i-1,1))
2466         else
2467           iti1=ntortyp+1
2468         endif
2469 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2470 !d        write (iout,*) '*******i',i,' iti1',iti
2471 !d        write (iout,*) 'b1',b1(:,iti)
2472 !d        write (iout,*) 'b2',b2(:,iti)
2473 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2474 !        if (i .gt. iatel_s+2) then
2475         if (i .gt. nnt+2) then
2476           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2477           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2478           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2479           then
2480           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2481           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2482           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2483           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2484           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2485           endif
2486         else
2487           do k=1,2
2488             Ub2(k,i-2)=0.0d0
2489             Ctobr(k,i-2)=0.0d0
2490             Dtobr2(k,i-2)=0.0d0
2491             do l=1,2
2492               EUg(l,k,i-2)=0.0d0
2493               CUg(l,k,i-2)=0.0d0
2494               DUg(l,k,i-2)=0.0d0
2495               DtUg2(l,k,i-2)=0.0d0
2496             enddo
2497           enddo
2498         endif
2499         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2500         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2501         do k=1,2
2502           muder(k,i-2)=Ub2der(k,i-2)
2503         enddo
2504 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2505         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2506           if (itype(i-1,1).le.ntyp) then
2507             iti1 = itortyp(itype(i-1,1))
2508           else
2509             iti1=ntortyp+1
2510           endif
2511         else
2512           iti1=ntortyp+1
2513         endif
2514         do k=1,2
2515           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2516         enddo
2517 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2518 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2519 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2520 !d        write (iout,*) 'mu1',mu1(:,i-2)
2521 !d        write (iout,*) 'mu2',mu2(:,i-2)
2522         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2523         then
2524         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2525         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2526         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2527         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2528         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2529 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2530         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2531         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2532         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2533         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2534         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2535         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2536         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2537         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2538         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2539         endif
2540       enddo
2541 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2542 ! The order of matrices is from left to right.
2543       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2544       then
2545 !      do i=max0(ivec_start,2),ivec_end
2546       do i=2,nres-1
2547         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2548         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2549         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2550         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2551         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2552         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2553         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2554         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2555       enddo
2556       endif
2557 #if defined(MPI) && defined(PARMAT)
2558 #ifdef DEBUG
2559 !      if (fg_rank.eq.0) then
2560         write (iout,*) "Arrays UG and UGDER before GATHER"
2561         do i=1,nres-1
2562           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2563            ((ug(l,k,i),l=1,2),k=1,2),&
2564            ((ugder(l,k,i),l=1,2),k=1,2)
2565         enddo
2566         write (iout,*) "Arrays UG2 and UG2DER"
2567         do i=1,nres-1
2568           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2569            ((ug2(l,k,i),l=1,2),k=1,2),&
2570            ((ug2der(l,k,i),l=1,2),k=1,2)
2571         enddo
2572         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2573         do i=1,nres-1
2574           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2575            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2576            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2577         enddo
2578         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2579         do i=1,nres-1
2580           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2581            costab(i),sintab(i),costab2(i),sintab2(i)
2582         enddo
2583         write (iout,*) "Array MUDER"
2584         do i=1,nres-1
2585           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2586         enddo
2587 !      endif
2588 #endif
2589       if (nfgtasks.gt.1) then
2590         time00=MPI_Wtime()
2591 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2592 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2593 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2594 #ifdef MATGATHER
2595         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2596          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2597          FG_COMM1,IERR)
2598         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2599          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2600          FG_COMM1,IERR)
2601         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2602          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2603          FG_COMM1,IERR)
2604         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2605          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2606          FG_COMM1,IERR)
2607         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2608          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2609          FG_COMM1,IERR)
2610         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2611          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2612          FG_COMM1,IERR)
2613         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2614          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2615          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2616         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2617          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2618          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2619         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2620          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2621          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2622         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2623          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2624          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2625         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2626         then
2627         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2628          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2629          FG_COMM1,IERR)
2630         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2631          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2632          FG_COMM1,IERR)
2633         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2634          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2635          FG_COMM1,IERR)
2636        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2637          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2638          FG_COMM1,IERR)
2639         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2640          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2641          FG_COMM1,IERR)
2642         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2643          ivec_count(fg_rank1),&
2644          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2645          FG_COMM1,IERR)
2646         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2647          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2648          FG_COMM1,IERR)
2649         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2650          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2651          FG_COMM1,IERR)
2652         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2653          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2654          FG_COMM1,IERR)
2655         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2656          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2657          FG_COMM1,IERR)
2658         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2659          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2660          FG_COMM1,IERR)
2661         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2662          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2663          FG_COMM1,IERR)
2664         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2665          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2666          FG_COMM1,IERR)
2667         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2668          ivec_count(fg_rank1),&
2669          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2670          FG_COMM1,IERR)
2671         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2672          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2673          FG_COMM1,IERR)
2674        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2675          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2676          FG_COMM1,IERR)
2677         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2678          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2679          FG_COMM1,IERR)
2680        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2681          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2682          FG_COMM1,IERR)
2683         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2684          ivec_count(fg_rank1),&
2685          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2686          FG_COMM1,IERR)
2687         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2688          ivec_count(fg_rank1),&
2689          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2690          FG_COMM1,IERR)
2691         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2692          ivec_count(fg_rank1),&
2693          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2694          MPI_MAT2,FG_COMM1,IERR)
2695         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2696          ivec_count(fg_rank1),&
2697          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2698          MPI_MAT2,FG_COMM1,IERR)
2699         endif
2700 #else
2701 ! Passes matrix info through the ring
2702       isend=fg_rank1
2703       irecv=fg_rank1-1
2704       if (irecv.lt.0) irecv=nfgtasks1-1
2705       iprev=irecv
2706       inext=fg_rank1+1
2707       if (inext.ge.nfgtasks1) inext=0
2708       do i=1,nfgtasks1-1
2709 !        write (iout,*) "isend",isend," irecv",irecv
2710 !        call flush(iout)
2711         lensend=lentyp(isend)
2712         lenrecv=lentyp(irecv)
2713 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2714 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2715 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2716 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2717 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2718 !        write (iout,*) "Gather ROTAT1"
2719 !        call flush(iout)
2720 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2721 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2722 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2723 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2724 !        write (iout,*) "Gather ROTAT2"
2725 !        call flush(iout)
2726         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2727          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2728          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2729          iprev,4400+irecv,FG_COMM,status,IERR)
2730 !        write (iout,*) "Gather ROTAT_OLD"
2731 !        call flush(iout)
2732         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2733          MPI_PRECOMP11(lensend),inext,5500+isend,&
2734          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2735          iprev,5500+irecv,FG_COMM,status,IERR)
2736 !        write (iout,*) "Gather PRECOMP11"
2737 !        call flush(iout)
2738         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2739          MPI_PRECOMP12(lensend),inext,6600+isend,&
2740          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2741          iprev,6600+irecv,FG_COMM,status,IERR)
2742 !        write (iout,*) "Gather PRECOMP12"
2743 !        call flush(iout)
2744         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2745         then
2746         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2747          MPI_ROTAT2(lensend),inext,7700+isend,&
2748          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2749          iprev,7700+irecv,FG_COMM,status,IERR)
2750 !        write (iout,*) "Gather PRECOMP21"
2751 !        call flush(iout)
2752         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2753          MPI_PRECOMP22(lensend),inext,8800+isend,&
2754          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2755          iprev,8800+irecv,FG_COMM,status,IERR)
2756 !        write (iout,*) "Gather PRECOMP22"
2757 !        call flush(iout)
2758         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2759          MPI_PRECOMP23(lensend),inext,9900+isend,&
2760          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2761          MPI_PRECOMP23(lenrecv),&
2762          iprev,9900+irecv,FG_COMM,status,IERR)
2763 !        write (iout,*) "Gather PRECOMP23"
2764 !        call flush(iout)
2765         endif
2766         isend=irecv
2767         irecv=irecv-1
2768         if (irecv.lt.0) irecv=nfgtasks1-1
2769       enddo
2770 #endif
2771         time_gather=time_gather+MPI_Wtime()-time00
2772       endif
2773 #ifdef DEBUG
2774 !      if (fg_rank.eq.0) then
2775         write (iout,*) "Arrays UG and UGDER"
2776         do i=1,nres-1
2777           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2778            ((ug(l,k,i),l=1,2),k=1,2),&
2779            ((ugder(l,k,i),l=1,2),k=1,2)
2780         enddo
2781         write (iout,*) "Arrays UG2 and UG2DER"
2782         do i=1,nres-1
2783           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2784            ((ug2(l,k,i),l=1,2),k=1,2),&
2785            ((ug2der(l,k,i),l=1,2),k=1,2)
2786         enddo
2787         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2788         do i=1,nres-1
2789           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2790            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2791            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2792         enddo
2793         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2794         do i=1,nres-1
2795           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2796            costab(i),sintab(i),costab2(i),sintab2(i)
2797         enddo
2798         write (iout,*) "Array MUDER"
2799         do i=1,nres-1
2800           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2801         enddo
2802 !      endif
2803 #endif
2804 #endif
2805 !d      do i=1,nres
2806 !d        iti = itortyp(itype(i,1))
2807 !d        write (iout,*) i
2808 !d        do j=1,2
2809 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2810 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2811 !d        enddo
2812 !d      enddo
2813       return
2814       end subroutine set_matrices
2815 !-----------------------------------------------------------------------------
2816       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2817 !
2818 ! This subroutine calculates the average interaction energy and its gradient
2819 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2820 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2821 ! The potential depends both on the distance of peptide-group centers and on
2822 ! the orientation of the CA-CA virtual bonds.
2823 !
2824       use comm_locel
2825 !      implicit real*8 (a-h,o-z)
2826 #ifdef MPI
2827       include 'mpif.h'
2828 #endif
2829 !      include 'DIMENSIONS'
2830 !      include 'COMMON.CONTROL'
2831 !      include 'COMMON.SETUP'
2832 !      include 'COMMON.IOUNITS'
2833 !      include 'COMMON.GEO'
2834 !      include 'COMMON.VAR'
2835 !      include 'COMMON.LOCAL'
2836 !      include 'COMMON.CHAIN'
2837 !      include 'COMMON.DERIV'
2838 !      include 'COMMON.INTERACT'
2839 !      include 'COMMON.CONTACTS'
2840 !      include 'COMMON.TORSION'
2841 !      include 'COMMON.VECTORS'
2842 !      include 'COMMON.FFIELD'
2843 !      include 'COMMON.TIME1'
2844       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2845       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2846       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2847 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2848       real(kind=8),dimension(4) :: muij
2849 !el      integer :: num_conti,j1,j2
2850 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2851 !el        dz_normi,xmedi,ymedi,zmedi
2852
2853 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2854 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2855 !el          num_conti,j1,j2
2856
2857 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2858 #ifdef MOMENT
2859       real(kind=8) :: scal_el=1.0d0
2860 #else
2861       real(kind=8) :: scal_el=0.5d0
2862 #endif
2863 ! 12/13/98
2864 ! 13-go grudnia roku pamietnego...
2865       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2866                                              0.0d0,1.0d0,0.0d0,&
2867                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2868 !el local variables
2869       integer :: i,k,j
2870       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2871       real(kind=8) :: fac,t_eelecij,fracinbuf
2872
2873
2874 !d      write(iout,*) 'In EELEC'
2875 !        print *,"IN EELEC"
2876 !d      do i=1,nloctyp
2877 !d        write(iout,*) 'Type',i
2878 !d        write(iout,*) 'B1',B1(:,i)
2879 !d        write(iout,*) 'B2',B2(:,i)
2880 !d        write(iout,*) 'CC',CC(:,:,i)
2881 !d        write(iout,*) 'DD',DD(:,:,i)
2882 !d        write(iout,*) 'EE',EE(:,:,i)
2883 !d      enddo
2884 !d      call check_vecgrad
2885 !d      stop
2886 !      ees=0.0d0  !AS
2887 !      evdw1=0.0d0
2888 !      eel_loc=0.0d0
2889 !      eello_turn3=0.0d0
2890 !      eello_turn4=0.0d0
2891       t_eelecij=0.0d0
2892       ees=0.0D0
2893       evdw1=0.0D0
2894       eel_loc=0.0d0
2895       eello_turn3=0.0d0
2896       eello_turn4=0.0d0
2897 !
2898
2899       if (icheckgrad.eq.1) then
2900 !el
2901 !        do i=0,2*nres+2
2902 !          dc_norm(1,i)=0.0d0
2903 !          dc_norm(2,i)=0.0d0
2904 !          dc_norm(3,i)=0.0d0
2905 !        enddo
2906         do i=1,nres-1
2907           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2908           do k=1,3
2909             dc_norm(k,i)=dc(k,i)*fac
2910           enddo
2911 !          write (iout,*) 'i',i,' fac',fac
2912         enddo
2913       endif
2914 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
2915 !        wturn6
2916       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
2917           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
2918           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2919 !        call vec_and_deriv
2920 #ifdef TIMING
2921         time01=MPI_Wtime()
2922 #endif
2923 !        print *, "before set matrices"
2924         call set_matrices
2925 !        print *, "after set matrices"
2926
2927 #ifdef TIMING
2928         time_mat=time_mat+MPI_Wtime()-time01
2929 #endif
2930       endif
2931 !       print *, "after set matrices"
2932 !d      do i=1,nres-1
2933 !d        write (iout,*) 'i=',i
2934 !d        do k=1,3
2935 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2936 !d        enddo
2937 !d        do k=1,3
2938 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2939 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2940 !d        enddo
2941 !d      enddo
2942       t_eelecij=0.0d0
2943       ees=0.0D0
2944       evdw1=0.0D0
2945       eel_loc=0.0d0
2946       eello_turn3=0.0d0
2947       eello_turn4=0.0d0
2948 !el      ind=0
2949       do i=1,nres
2950         num_cont_hb(i)=0
2951       enddo
2952 !d      print '(a)','Enter EELEC'
2953 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2954 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
2955 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
2956       do i=1,nres
2957         gel_loc_loc(i)=0.0d0
2958         gcorr_loc(i)=0.0d0
2959       enddo
2960 !
2961 !
2962 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2963 !
2964 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
2965 !
2966
2967
2968 !        print *,"before iturn3 loop"
2969       do i=iturn3_start,iturn3_end
2970         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
2971         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
2972         dxi=dc(1,i)
2973         dyi=dc(2,i)
2974         dzi=dc(3,i)
2975         dx_normi=dc_norm(1,i)
2976         dy_normi=dc_norm(2,i)
2977         dz_normi=dc_norm(3,i)
2978         xmedi=c(1,i)+0.5d0*dxi
2979         ymedi=c(2,i)+0.5d0*dyi
2980         zmedi=c(3,i)+0.5d0*dzi
2981           xmedi=dmod(xmedi,boxxsize)
2982           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2983           ymedi=dmod(ymedi,boxysize)
2984           if (ymedi.lt.0) ymedi=ymedi+boxysize
2985           zmedi=dmod(zmedi,boxzsize)
2986           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2987         num_conti=0
2988        if ((zmedi.gt.bordlipbot) &
2989         .and.(zmedi.lt.bordliptop)) then
2990 !C the energy transfer exist
2991         if (zmedi.lt.buflipbot) then
2992 !C what fraction I am in
2993          fracinbuf=1.0d0- &
2994                ((zmedi-bordlipbot)/lipbufthick)
2995 !C lipbufthick is thickenes of lipid buffore
2996          sslipi=sscalelip(fracinbuf)
2997          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2998         elseif (zmedi.gt.bufliptop) then
2999          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3000          sslipi=sscalelip(fracinbuf)
3001          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3002         else
3003          sslipi=1.0d0
3004          ssgradlipi=0.0
3005         endif
3006        else
3007          sslipi=0.0d0
3008          ssgradlipi=0.0
3009        endif
3010 !       print *,i,sslipi,ssgradlipi
3011        call eelecij(i,i+2,ees,evdw1,eel_loc)
3012         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3013         num_cont_hb(i)=num_conti
3014       enddo
3015       do i=iturn4_start,iturn4_end
3016         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3017           .or. itype(i+3,1).eq.ntyp1 &
3018           .or. itype(i+4,1).eq.ntyp1) cycle
3019         dxi=dc(1,i)
3020         dyi=dc(2,i)
3021         dzi=dc(3,i)
3022         dx_normi=dc_norm(1,i)
3023         dy_normi=dc_norm(2,i)
3024         dz_normi=dc_norm(3,i)
3025         xmedi=c(1,i)+0.5d0*dxi
3026         ymedi=c(2,i)+0.5d0*dyi
3027         zmedi=c(3,i)+0.5d0*dzi
3028           xmedi=dmod(xmedi,boxxsize)
3029           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3030           ymedi=dmod(ymedi,boxysize)
3031           if (ymedi.lt.0) ymedi=ymedi+boxysize
3032           zmedi=dmod(zmedi,boxzsize)
3033           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3034        if ((zmedi.gt.bordlipbot)  &
3035        .and.(zmedi.lt.bordliptop)) then
3036 !C the energy transfer exist
3037         if (zmedi.lt.buflipbot) then
3038 !C what fraction I am in
3039          fracinbuf=1.0d0- &
3040              ((zmedi-bordlipbot)/lipbufthick)
3041 !C lipbufthick is thickenes of lipid buffore
3042          sslipi=sscalelip(fracinbuf)
3043          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3044         elseif (zmedi.gt.bufliptop) then
3045          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3046          sslipi=sscalelip(fracinbuf)
3047          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3048         else
3049          sslipi=1.0d0
3050          ssgradlipi=0.0
3051         endif
3052        else
3053          sslipi=0.0d0
3054          ssgradlipi=0.0
3055        endif
3056
3057         num_conti=num_cont_hb(i)
3058         call eelecij(i,i+3,ees,evdw1,eel_loc)
3059         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3060          call eturn4(i,eello_turn4)
3061         num_cont_hb(i)=num_conti
3062       enddo   ! i
3063 !
3064 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3065 !
3066       do i=iatel_s,iatel_e
3067         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3068         dxi=dc(1,i)
3069         dyi=dc(2,i)
3070         dzi=dc(3,i)
3071         dx_normi=dc_norm(1,i)
3072         dy_normi=dc_norm(2,i)
3073         dz_normi=dc_norm(3,i)
3074         xmedi=c(1,i)+0.5d0*dxi
3075         ymedi=c(2,i)+0.5d0*dyi
3076         zmedi=c(3,i)+0.5d0*dzi
3077           xmedi=dmod(xmedi,boxxsize)
3078           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3079           ymedi=dmod(ymedi,boxysize)
3080           if (ymedi.lt.0) ymedi=ymedi+boxysize
3081           zmedi=dmod(zmedi,boxzsize)
3082           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3083        if ((zmedi.gt.bordlipbot)  &
3084         .and.(zmedi.lt.bordliptop)) then
3085 !C the energy transfer exist
3086         if (zmedi.lt.buflipbot) then
3087 !C what fraction I am in
3088          fracinbuf=1.0d0- &
3089              ((zmedi-bordlipbot)/lipbufthick)
3090 !C lipbufthick is thickenes of lipid buffore
3091          sslipi=sscalelip(fracinbuf)
3092          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3093         elseif (zmedi.gt.bufliptop) then
3094          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3095          sslipi=sscalelip(fracinbuf)
3096          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3097         else
3098          sslipi=1.0d0
3099          ssgradlipi=0.0
3100         endif
3101        else
3102          sslipi=0.0d0
3103          ssgradlipi=0.0
3104        endif
3105
3106 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3107         num_conti=num_cont_hb(i)
3108         do j=ielstart(i),ielend(i)
3109 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3110           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3111           call eelecij(i,j,ees,evdw1,eel_loc)
3112         enddo ! j
3113         num_cont_hb(i)=num_conti
3114       enddo   ! i
3115 !      write (iout,*) "Number of loop steps in EELEC:",ind
3116 !d      do i=1,nres
3117 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3118 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3119 !d      enddo
3120 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3121 !cc      eel_loc=eel_loc+eello_turn3
3122 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3123       return
3124       end subroutine eelec
3125 !-----------------------------------------------------------------------------
3126       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3127
3128       use comm_locel
3129 !      implicit real*8 (a-h,o-z)
3130 !      include 'DIMENSIONS'
3131 #ifdef MPI
3132       include "mpif.h"
3133 #endif
3134 !      include 'COMMON.CONTROL'
3135 !      include 'COMMON.IOUNITS'
3136 !      include 'COMMON.GEO'
3137 !      include 'COMMON.VAR'
3138 !      include 'COMMON.LOCAL'
3139 !      include 'COMMON.CHAIN'
3140 !      include 'COMMON.DERIV'
3141 !      include 'COMMON.INTERACT'
3142 !      include 'COMMON.CONTACTS'
3143 !      include 'COMMON.TORSION'
3144 !      include 'COMMON.VECTORS'
3145 !      include 'COMMON.FFIELD'
3146 !      include 'COMMON.TIME1'
3147       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3148       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3149       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3150 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3151       real(kind=8),dimension(4) :: muij
3152       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3153                     dist_temp, dist_init,rlocshield,fracinbuf
3154       integer xshift,yshift,zshift,ilist,iresshield
3155 !el      integer :: num_conti,j1,j2
3156 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3157 !el        dz_normi,xmedi,ymedi,zmedi
3158
3159 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3160 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3161 !el          num_conti,j1,j2
3162
3163 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3164 #ifdef MOMENT
3165       real(kind=8) :: scal_el=1.0d0
3166 #else
3167       real(kind=8) :: scal_el=0.5d0
3168 #endif
3169 ! 12/13/98
3170 ! 13-go grudnia roku pamietnego...
3171       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3172                                              0.0d0,1.0d0,0.0d0,&
3173                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3174 !      integer :: maxconts=nres/4
3175 !el local variables
3176       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3177       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3178       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3179       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3180                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3181                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3182                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3183                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3184                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3185                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3186                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3187 !      maxconts=nres/4
3188 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3189 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3190
3191 !          time00=MPI_Wtime()
3192 !d      write (iout,*) "eelecij",i,j
3193 !          ind=ind+1
3194           iteli=itel(i)
3195           itelj=itel(j)
3196           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3197           aaa=app_nucl(iteli,itelj)
3198           bbb=bpp_nucl(iteli,itelj)
3199           ael6i=ael6_nucl(iteli,itelj)
3200           ael3i=ael3_nucl(iteli,itelj)
3201           dxj=dc(1,j)
3202           dyj=dc(2,j)
3203           dzj=dc(3,j)
3204           dx_normj=dc_norm(1,j)
3205           dy_normj=dc_norm(2,j)
3206           dz_normj=dc_norm(3,j)
3207 !          xj=c(1,j)+0.5D0*dxj-xmedi
3208 !          yj=c(2,j)+0.5D0*dyj-ymedi
3209 !          zj=c(3,j)+0.5D0*dzj-zmedi
3210           xj=c(1,j)+0.5D0*dxj
3211           yj=c(2,j)+0.5D0*dyj
3212           zj=c(3,j)+0.5D0*dzj
3213           xj=mod(xj,boxxsize)
3214           if (xj.lt.0) xj=xj+boxxsize
3215           yj=mod(yj,boxysize)
3216           if (yj.lt.0) yj=yj+boxysize
3217           zj=mod(zj,boxzsize)
3218           if (zj.lt.0) zj=zj+boxzsize
3219        if ((zj.gt.bordlipbot)  &
3220        .and.(zj.lt.bordliptop)) then
3221 !C the energy transfer exist
3222         if (zj.lt.buflipbot) then
3223 !C what fraction I am in
3224          fracinbuf=1.0d0-     &
3225              ((zj-bordlipbot)/lipbufthick)
3226 !C lipbufthick is thickenes of lipid buffore
3227          sslipj=sscalelip(fracinbuf)
3228          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3229         elseif (zj.gt.bufliptop) then
3230          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3231          sslipj=sscalelip(fracinbuf)
3232          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3233         else
3234          sslipj=1.0d0
3235          ssgradlipj=0.0
3236         endif
3237        else
3238          sslipj=0.0d0
3239          ssgradlipj=0.0
3240        endif
3241
3242       isubchap=0
3243       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3244       xj_safe=xj
3245       yj_safe=yj
3246       zj_safe=zj
3247       do xshift=-1,1
3248       do yshift=-1,1
3249       do zshift=-1,1
3250           xj=xj_safe+xshift*boxxsize
3251           yj=yj_safe+yshift*boxysize
3252           zj=zj_safe+zshift*boxzsize
3253           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3254           if(dist_temp.lt.dist_init) then
3255             dist_init=dist_temp
3256             xj_temp=xj
3257             yj_temp=yj
3258             zj_temp=zj
3259             isubchap=1
3260           endif
3261        enddo
3262        enddo
3263        enddo
3264        if (isubchap.eq.1) then
3265 !C          print *,i,j
3266           xj=xj_temp-xmedi
3267           yj=yj_temp-ymedi
3268           zj=zj_temp-zmedi
3269        else
3270           xj=xj_safe-xmedi
3271           yj=yj_safe-ymedi
3272           zj=zj_safe-zmedi
3273        endif
3274
3275           rij=xj*xj+yj*yj+zj*zj
3276           rrmij=1.0D0/rij
3277           rij=dsqrt(rij)
3278 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3279             sss_ele_cut=sscale_ele(rij)
3280             sss_ele_grad=sscagrad_ele(rij)
3281 !             sss_ele_cut=1.0d0
3282 !             sss_ele_grad=0.0d0
3283 !            print *,sss_ele_cut,sss_ele_grad,&
3284 !            (rij),r_cut_ele,rlamb_ele
3285 !            if (sss_ele_cut.le.0.0) go to 128
3286
3287           rmij=1.0D0/rij
3288           r3ij=rrmij*rmij
3289           r6ij=r3ij*r3ij
3290           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3291           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3292           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3293           fac=cosa-3.0D0*cosb*cosg
3294           ev1=aaa*r6ij*r6ij
3295 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3296           if (j.eq.i+2) ev1=scal_el*ev1
3297           ev2=bbb*r6ij
3298           fac3=ael6i*r6ij
3299           fac4=ael3i*r3ij
3300           evdwij=ev1+ev2
3301           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3302           el2=fac4*fac
3303 !          eesij=el1+el2
3304           if (shield_mode.gt.0) then
3305 !C          fac_shield(i)=0.4
3306 !C          fac_shield(j)=0.6
3307           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3308           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3309           eesij=(el1+el2)
3310           ees=ees+eesij*sss_ele_cut
3311 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3312 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3313           else
3314           fac_shield(i)=1.0
3315           fac_shield(j)=1.0
3316           eesij=(el1+el2)
3317           ees=ees+eesij   &
3318             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3319 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3320           endif
3321
3322 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3323           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3324 !          ees=ees+eesij*sss_ele_cut
3325           evdw1=evdw1+evdwij*sss_ele_cut  &
3326            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3327 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3328 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3329 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3330 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3331
3332           if (energy_dec) then
3333 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3334 !                  'evdw1',i,j,evdwij,&
3335 !                  iteli,itelj,aaa,evdw1
3336               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3337               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3338           endif
3339 !
3340 ! Calculate contributions to the Cartesian gradient.
3341 !
3342 #ifdef SPLITELE
3343           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3344               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3345           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3346              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3347           fac1=fac
3348           erij(1)=xj*rmij
3349           erij(2)=yj*rmij
3350           erij(3)=zj*rmij
3351 !
3352 ! Radial derivatives. First process both termini of the fragment (i,j)
3353 !
3354           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3355           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3356           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3357            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3358           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3359             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3360
3361           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3362           (shield_mode.gt.0)) then
3363 !C          print *,i,j
3364           do ilist=1,ishield_list(i)
3365            iresshield=shield_list(ilist,i)
3366            do k=1,3
3367            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3368            *2.0*sss_ele_cut
3369            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3370                    rlocshield &
3371             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3372             *sss_ele_cut
3373             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3374            enddo
3375           enddo
3376           do ilist=1,ishield_list(j)
3377            iresshield=shield_list(ilist,j)
3378            do k=1,3
3379            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3380           *2.0*sss_ele_cut
3381            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3382                    rlocshield &
3383            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3384            *sss_ele_cut
3385            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3386            enddo
3387           enddo
3388           do k=1,3
3389             gshieldc(k,i)=gshieldc(k,i)+ &
3390                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3391            *sss_ele_cut
3392
3393             gshieldc(k,j)=gshieldc(k,j)+ &
3394                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3395            *sss_ele_cut
3396
3397             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3398                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3399            *sss_ele_cut
3400
3401             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3402                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3403            *sss_ele_cut
3404
3405            enddo
3406            endif
3407
3408
3409 !          do k=1,3
3410 !            ghalf=0.5D0*ggg(k)
3411 !            gelc(k,i)=gelc(k,i)+ghalf
3412 !            gelc(k,j)=gelc(k,j)+ghalf
3413 !          enddo
3414 ! 9/28/08 AL Gradient compotents will be summed only at the end
3415           do k=1,3
3416             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3417             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3418           enddo
3419             gelc_long(3,j)=gelc_long(3,j)+  &
3420           ssgradlipj*eesij/2.0d0*lipscale**2&
3421            *sss_ele_cut
3422
3423             gelc_long(3,i)=gelc_long(3,i)+  &
3424           ssgradlipi*eesij/2.0d0*lipscale**2&
3425            *sss_ele_cut
3426
3427
3428 !
3429 ! Loop over residues i+1 thru j-1.
3430 !
3431 !grad          do k=i+1,j-1
3432 !grad            do l=1,3
3433 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3434 !grad            enddo
3435 !grad          enddo
3436           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3437            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3438           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3439            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3440           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3441            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3442
3443 !          do k=1,3
3444 !            ghalf=0.5D0*ggg(k)
3445 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3446 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3447 !          enddo
3448 ! 9/28/08 AL Gradient compotents will be summed only at the end
3449           do k=1,3
3450             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3451             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3452           enddo
3453
3454 !C Lipidic part for scaling weight
3455            gvdwpp(3,j)=gvdwpp(3,j)+ &
3456           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3457            gvdwpp(3,i)=gvdwpp(3,i)+ &
3458           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3459 !! Loop over residues i+1 thru j-1.
3460 !
3461 !grad          do k=i+1,j-1
3462 !grad            do l=1,3
3463 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3464 !grad            enddo
3465 !grad          enddo
3466 #else
3467           facvdw=(ev1+evdwij)*sss_ele_cut &
3468            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3469
3470           facel=(el1+eesij)*sss_ele_cut
3471           fac1=fac
3472           fac=-3*rrmij*(facvdw+facvdw+facel)
3473           erij(1)=xj*rmij
3474           erij(2)=yj*rmij
3475           erij(3)=zj*rmij
3476 !
3477 ! Radial derivatives. First process both termini of the fragment (i,j)
3478 !
3479           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3480           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3481           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3482 !          do k=1,3
3483 !            ghalf=0.5D0*ggg(k)
3484 !            gelc(k,i)=gelc(k,i)+ghalf
3485 !            gelc(k,j)=gelc(k,j)+ghalf
3486 !          enddo
3487 ! 9/28/08 AL Gradient compotents will be summed only at the end
3488           do k=1,3
3489             gelc_long(k,j)=gelc(k,j)+ggg(k)
3490             gelc_long(k,i)=gelc(k,i)-ggg(k)
3491           enddo
3492 !
3493 ! Loop over residues i+1 thru j-1.
3494 !
3495 !grad          do k=i+1,j-1
3496 !grad            do l=1,3
3497 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3498 !grad            enddo
3499 !grad          enddo
3500 ! 9/28/08 AL Gradient compotents will be summed only at the end
3501           ggg(1)=facvdw*xj &
3502            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3503           ggg(2)=facvdw*yj &
3504            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3505           ggg(3)=facvdw*zj &
3506            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3507
3508           do k=1,3
3509             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3510             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3511           enddo
3512            gvdwpp(3,j)=gvdwpp(3,j)+ &
3513           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3514            gvdwpp(3,i)=gvdwpp(3,i)+ &
3515           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3516
3517 #endif
3518 !
3519 ! Angular part
3520 !
3521           ecosa=2.0D0*fac3*fac1+fac4
3522           fac4=-3.0D0*fac4
3523           fac3=-6.0D0*fac3
3524           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3525           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3526           do k=1,3
3527             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3528             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3529           enddo
3530 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3531 !d   &          (dcosg(k),k=1,3)
3532           do k=1,3
3533             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3534              *fac_shield(i)**2*fac_shield(j)**2 &
3535              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3536
3537           enddo
3538 !          do k=1,3
3539 !            ghalf=0.5D0*ggg(k)
3540 !            gelc(k,i)=gelc(k,i)+ghalf
3541 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3542 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3543 !            gelc(k,j)=gelc(k,j)+ghalf
3544 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3545 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3546 !          enddo
3547 !grad          do k=i+1,j-1
3548 !grad            do l=1,3
3549 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3550 !grad            enddo
3551 !grad          enddo
3552           do k=1,3
3553             gelc(k,i)=gelc(k,i) &
3554                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3555                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3556                      *sss_ele_cut &
3557                      *fac_shield(i)**2*fac_shield(j)**2 &
3558                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3559
3560             gelc(k,j)=gelc(k,j) &
3561                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3562                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3563                      *sss_ele_cut  &
3564                      *fac_shield(i)**2*fac_shield(j)**2  &
3565                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3566
3567             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3568             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3569           enddo
3570
3571           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3572               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3573               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3574 !
3575 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3576 !   energy of a peptide unit is assumed in the form of a second-order
3577 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3578 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3579 !   are computed for EVERY pair of non-contiguous peptide groups.
3580 !
3581           if (j.lt.nres-1) then
3582             j1=j+1
3583             j2=j-1
3584           else
3585             j1=j-1
3586             j2=j-2
3587           endif
3588           kkk=0
3589           do k=1,2
3590             do l=1,2
3591               kkk=kkk+1
3592               muij(kkk)=mu(k,i)*mu(l,j)
3593             enddo
3594           enddo
3595 !d         write (iout,*) 'EELEC: i',i,' j',j
3596 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3597 !d          write(iout,*) 'muij',muij
3598           ury=scalar(uy(1,i),erij)
3599           urz=scalar(uz(1,i),erij)
3600           vry=scalar(uy(1,j),erij)
3601           vrz=scalar(uz(1,j),erij)
3602           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3603           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3604           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3605           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3606           fac=dsqrt(-ael6i)*r3ij
3607           a22=a22*fac
3608           a23=a23*fac
3609           a32=a32*fac
3610           a33=a33*fac
3611 !d          write (iout,'(4i5,4f10.5)')
3612 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3613 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3614 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3615 !d     &      uy(:,j),uz(:,j)
3616 !d          write (iout,'(4f10.5)')
3617 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3618 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3619 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3620 !d           write (iout,'(9f10.5/)')
3621 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3622 ! Derivatives of the elements of A in virtual-bond vectors
3623           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3624           do k=1,3
3625             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3626             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3627             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3628             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3629             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3630             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3631             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3632             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3633             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3634             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3635             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3636             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3637           enddo
3638 ! Compute radial contributions to the gradient
3639           facr=-3.0d0*rrmij
3640           a22der=a22*facr
3641           a23der=a23*facr
3642           a32der=a32*facr
3643           a33der=a33*facr
3644           agg(1,1)=a22der*xj
3645           agg(2,1)=a22der*yj
3646           agg(3,1)=a22der*zj
3647           agg(1,2)=a23der*xj
3648           agg(2,2)=a23der*yj
3649           agg(3,2)=a23der*zj
3650           agg(1,3)=a32der*xj
3651           agg(2,3)=a32der*yj
3652           agg(3,3)=a32der*zj
3653           agg(1,4)=a33der*xj
3654           agg(2,4)=a33der*yj
3655           agg(3,4)=a33der*zj
3656 ! Add the contributions coming from er
3657           fac3=-3.0d0*fac
3658           do k=1,3
3659             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3660             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3661             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3662             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3663           enddo
3664           do k=1,3
3665 ! Derivatives in DC(i)
3666 !grad            ghalf1=0.5d0*agg(k,1)
3667 !grad            ghalf2=0.5d0*agg(k,2)
3668 !grad            ghalf3=0.5d0*agg(k,3)
3669 !grad            ghalf4=0.5d0*agg(k,4)
3670             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3671             -3.0d0*uryg(k,2)*vry)!+ghalf1
3672             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3673             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3674             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3675             -3.0d0*urzg(k,2)*vry)!+ghalf3
3676             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3677             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3678 ! Derivatives in DC(i+1)
3679             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3680             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3681             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3682             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3683             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3684             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3685             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3686             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3687 ! Derivatives in DC(j)
3688             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3689             -3.0d0*vryg(k,2)*ury)!+ghalf1
3690             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3691             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3692             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3693             -3.0d0*vryg(k,2)*urz)!+ghalf3
3694             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3695             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3696 ! Derivatives in DC(j+1) or DC(nres-1)
3697             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3698             -3.0d0*vryg(k,3)*ury)
3699             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3700             -3.0d0*vrzg(k,3)*ury)
3701             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3702             -3.0d0*vryg(k,3)*urz)
3703             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3704             -3.0d0*vrzg(k,3)*urz)
3705 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3706 !grad              do l=1,4
3707 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3708 !grad              enddo
3709 !grad            endif
3710           enddo
3711           acipa(1,1)=a22
3712           acipa(1,2)=a23
3713           acipa(2,1)=a32
3714           acipa(2,2)=a33
3715           a22=-a22
3716           a23=-a23
3717           do l=1,2
3718             do k=1,3
3719               agg(k,l)=-agg(k,l)
3720               aggi(k,l)=-aggi(k,l)
3721               aggi1(k,l)=-aggi1(k,l)
3722               aggj(k,l)=-aggj(k,l)
3723               aggj1(k,l)=-aggj1(k,l)
3724             enddo
3725           enddo
3726           if (j.lt.nres-1) then
3727             a22=-a22
3728             a32=-a32
3729             do l=1,3,2
3730               do k=1,3
3731                 agg(k,l)=-agg(k,l)
3732                 aggi(k,l)=-aggi(k,l)
3733                 aggi1(k,l)=-aggi1(k,l)
3734                 aggj(k,l)=-aggj(k,l)
3735                 aggj1(k,l)=-aggj1(k,l)
3736               enddo
3737             enddo
3738           else
3739             a22=-a22
3740             a23=-a23
3741             a32=-a32
3742             a33=-a33
3743             do l=1,4
3744               do k=1,3
3745                 agg(k,l)=-agg(k,l)
3746                 aggi(k,l)=-aggi(k,l)
3747                 aggi1(k,l)=-aggi1(k,l)
3748                 aggj(k,l)=-aggj(k,l)
3749                 aggj1(k,l)=-aggj1(k,l)
3750               enddo
3751             enddo
3752           endif
3753           ENDIF ! WCORR
3754           IF (wel_loc.gt.0.0d0) THEN
3755 ! Contribution to the local-electrostatic energy coming from the i-j pair
3756           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3757            +a33*muij(4)
3758           if (shield_mode.eq.0) then
3759            fac_shield(i)=1.0
3760            fac_shield(j)=1.0
3761           endif
3762           eel_loc_ij=eel_loc_ij &
3763          *fac_shield(i)*fac_shield(j) &
3764          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3765 !C Now derivative over eel_loc
3766           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3767          (shield_mode.gt.0)) then
3768 !C          print *,i,j
3769
3770           do ilist=1,ishield_list(i)
3771            iresshield=shield_list(ilist,i)
3772            do k=1,3
3773            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3774                                                 /fac_shield(i)&
3775            *sss_ele_cut
3776            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3777                    rlocshield  &
3778           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3779           *sss_ele_cut
3780
3781             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3782            +rlocshield
3783            enddo
3784           enddo
3785           do ilist=1,ishield_list(j)
3786            iresshield=shield_list(ilist,j)
3787            do k=1,3
3788            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3789                                             /fac_shield(j)   &
3790             *sss_ele_cut
3791            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3792                    rlocshield  &
3793       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3794        *sss_ele_cut
3795
3796            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3797                   +rlocshield
3798
3799            enddo
3800           enddo
3801
3802           do k=1,3
3803             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3804                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3805                     *sss_ele_cut
3806             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3807                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3808                     *sss_ele_cut
3809             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3810                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3811                     *sss_ele_cut
3812             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3813                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3814                     *sss_ele_cut
3815
3816            enddo
3817            endif
3818
3819
3820 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3821 !           eel_loc_ij=0.0
3822           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3823                   'eelloc',i,j,eel_loc_ij
3824 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3825 !          if (energy_dec) write (iout,*) "muij",muij
3826 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3827
3828           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3829 ! Partial derivatives in virtual-bond dihedral angles gamma
3830           if (i.gt.1) &
3831           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3832                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3833                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3834                  *sss_ele_cut  &
3835           *fac_shield(i)*fac_shield(j) &
3836           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3837
3838           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3839                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3840                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3841                  *sss_ele_cut &
3842           *fac_shield(i)*fac_shield(j) &
3843           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3844 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3845 !          do l=1,3
3846 !            ggg(1)=(agg(1,1)*muij(1)+ &
3847 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3848 !            *sss_ele_cut &
3849 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3850 !            ggg(2)=(agg(2,1)*muij(1)+ &
3851 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3852 !            *sss_ele_cut &
3853 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3854 !            ggg(3)=(agg(3,1)*muij(1)+ &
3855 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3856 !            *sss_ele_cut &
3857 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3858            xtemp(1)=xj
3859            xtemp(2)=yj
3860            xtemp(3)=zj
3861
3862            do l=1,3
3863             ggg(l)=(agg(l,1)*muij(1)+ &
3864                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3865             *sss_ele_cut &
3866           *fac_shield(i)*fac_shield(j) &
3867           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
3868              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3869
3870
3871             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3872             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3873 !grad            ghalf=0.5d0*ggg(l)
3874 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3875 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3876           enddo
3877             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
3878           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
3879           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3880
3881             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
3882           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
3883           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3884
3885 !grad          do k=i+1,j2
3886 !grad            do l=1,3
3887 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3888 !grad            enddo
3889 !grad          enddo
3890 ! Remaining derivatives of eello
3891           do l=1,3
3892             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
3893                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
3894             *sss_ele_cut &
3895           *fac_shield(i)*fac_shield(j) &
3896           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3897
3898 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3899             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
3900                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
3901             +aggi1(l,4)*muij(4))&
3902             *sss_ele_cut &
3903           *fac_shield(i)*fac_shield(j) &
3904           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3905
3906 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3907             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
3908                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
3909             *sss_ele_cut &
3910           *fac_shield(i)*fac_shield(j) &
3911           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3912
3913 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3914             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
3915                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
3916             +aggj1(l,4)*muij(4))&
3917             *sss_ele_cut &
3918           *fac_shield(i)*fac_shield(j) &
3919           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3920
3921 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3922           enddo
3923           ENDIF
3924 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
3925 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3926           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
3927              .and. num_conti.le.maxconts) then
3928 !            write (iout,*) i,j," entered corr"
3929 !
3930 ! Calculate the contact function. The ith column of the array JCONT will
3931 ! contain the numbers of atoms that make contacts with the atom I (of numbers
3932 ! greater than I). The arrays FACONT and GACONT will contain the values of
3933 ! the contact function and its derivative.
3934 !           r0ij=1.02D0*rpp(iteli,itelj)
3935 !           r0ij=1.11D0*rpp(iteli,itelj)
3936             r0ij=2.20D0*rpp(iteli,itelj)
3937 !           r0ij=1.55D0*rpp(iteli,itelj)
3938             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3939 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
3940             if (fcont.gt.0.0D0) then
3941               num_conti=num_conti+1
3942               if (num_conti.gt.maxconts) then
3943 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
3944 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
3945                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
3946                                ' will skip next contacts for this conf.', num_conti
3947               else
3948                 jcont_hb(num_conti,i)=j
3949 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
3950 !d     &           " jcont_hb",jcont_hb(num_conti,i)
3951                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
3952                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3953 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3954 !  terms.
3955                 d_cont(num_conti,i)=rij
3956 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3957 !     --- Electrostatic-interaction matrix ---
3958                 a_chuj(1,1,num_conti,i)=a22
3959                 a_chuj(1,2,num_conti,i)=a23
3960                 a_chuj(2,1,num_conti,i)=a32
3961                 a_chuj(2,2,num_conti,i)=a33
3962 !     --- Gradient of rij
3963                 do kkk=1,3
3964                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3965                 enddo
3966                 kkll=0
3967                 do k=1,2
3968                   do l=1,2
3969                     kkll=kkll+1
3970                     do m=1,3
3971                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3972                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3973                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3974                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3975                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3976                     enddo
3977                   enddo
3978                 enddo
3979                 ENDIF
3980                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3981 ! Calculate contact energies
3982                 cosa4=4.0D0*cosa
3983                 wij=cosa-3.0D0*cosb*cosg
3984                 cosbg1=cosb+cosg
3985                 cosbg2=cosb-cosg
3986 !               fac3=dsqrt(-ael6i)/r0ij**3
3987                 fac3=dsqrt(-ael6i)*r3ij
3988 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3989                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3990                 if (ees0tmp.gt.0) then
3991                   ees0pij=dsqrt(ees0tmp)
3992                 else
3993                   ees0pij=0
3994                 endif
3995                 if (shield_mode.eq.0) then
3996                 fac_shield(i)=1.0d0
3997                 fac_shield(j)=1.0d0
3998                 else
3999                 ees0plist(num_conti,i)=j
4000                 endif
4001 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4002                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4003                 if (ees0tmp.gt.0) then
4004                   ees0mij=dsqrt(ees0tmp)
4005                 else
4006                   ees0mij=0
4007                 endif
4008 !               ees0mij=0.0D0
4009                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4010                      *sss_ele_cut &
4011                      *fac_shield(i)*fac_shield(j)
4012
4013                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4014                      *sss_ele_cut &
4015                      *fac_shield(i)*fac_shield(j)
4016
4017 ! Diagnostics. Comment out or remove after debugging!
4018 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4019 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4020 !               ees0m(num_conti,i)=0.0D0
4021 ! End diagnostics.
4022 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4023 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4024 ! Angular derivatives of the contact function
4025                 ees0pij1=fac3/ees0pij
4026                 ees0mij1=fac3/ees0mij
4027                 fac3p=-3.0D0*fac3*rrmij
4028                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4029                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4030 !               ees0mij1=0.0D0
4031                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4032                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4033                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4034                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4035                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4036                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4037                 ecosap=ecosa1+ecosa2
4038                 ecosbp=ecosb1+ecosb2
4039                 ecosgp=ecosg1+ecosg2
4040                 ecosam=ecosa1-ecosa2
4041                 ecosbm=ecosb1-ecosb2
4042                 ecosgm=ecosg1-ecosg2
4043 ! Diagnostics
4044 !               ecosap=ecosa1
4045 !               ecosbp=ecosb1
4046 !               ecosgp=ecosg1
4047 !               ecosam=0.0D0
4048 !               ecosbm=0.0D0
4049 !               ecosgm=0.0D0
4050 ! End diagnostics
4051                 facont_hb(num_conti,i)=fcont
4052                 fprimcont=fprimcont/rij
4053 !d              facont_hb(num_conti,i)=1.0D0
4054 ! Following line is for diagnostics.
4055 !d              fprimcont=0.0D0
4056                 do k=1,3
4057                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4058                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4059                 enddo
4060                 do k=1,3
4061                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4062                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4063                 enddo
4064                 gggp(1)=gggp(1)+ees0pijp*xj &
4065                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4066                 gggp(2)=gggp(2)+ees0pijp*yj &
4067                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4068                 gggp(3)=gggp(3)+ees0pijp*zj &
4069                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4070
4071                 gggm(1)=gggm(1)+ees0mijp*xj &
4072                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4073
4074                 gggm(2)=gggm(2)+ees0mijp*yj &
4075                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4076
4077                 gggm(3)=gggm(3)+ees0mijp*zj &
4078                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4079
4080 ! Derivatives due to the contact function
4081                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4082                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4083                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4084                 do k=1,3
4085 !
4086 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4087 !          following the change of gradient-summation algorithm.
4088 !
4089 !grad                  ghalfp=0.5D0*gggp(k)
4090 !grad                  ghalfm=0.5D0*gggm(k)
4091                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4092                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4093                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4094                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4095
4096                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4097                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4098                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4099                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4100
4101                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4102                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4103
4104                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4105                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4106                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4107                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4108
4109                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4110                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4111                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4112                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4113
4114                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4115                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4116
4117                 enddo
4118 ! Diagnostics. Comment out or remove after debugging!
4119 !diag           do k=1,3
4120 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4121 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4122 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4123 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4124 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4125 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4126 !diag           enddo
4127               ENDIF ! wcorr
4128               endif  ! num_conti.le.maxconts
4129             endif  ! fcont.gt.0
4130           endif    ! j.gt.i+1
4131           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4132             do k=1,4
4133               do l=1,3
4134                 ghalf=0.5d0*agg(l,k)
4135                 aggi(l,k)=aggi(l,k)+ghalf
4136                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4137                 aggj(l,k)=aggj(l,k)+ghalf
4138               enddo
4139             enddo
4140             if (j.eq.nres-1 .and. i.lt.j-2) then
4141               do k=1,4
4142                 do l=1,3
4143                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4144                 enddo
4145               enddo
4146             endif
4147           endif
4148  128  continue
4149 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4150       return
4151       end subroutine eelecij
4152 !-----------------------------------------------------------------------------
4153       subroutine eturn3(i,eello_turn3)
4154 ! Third- and fourth-order contributions from turns
4155
4156       use comm_locel
4157 !      implicit real*8 (a-h,o-z)
4158 !      include 'DIMENSIONS'
4159 !      include 'COMMON.IOUNITS'
4160 !      include 'COMMON.GEO'
4161 !      include 'COMMON.VAR'
4162 !      include 'COMMON.LOCAL'
4163 !      include 'COMMON.CHAIN'
4164 !      include 'COMMON.DERIV'
4165 !      include 'COMMON.INTERACT'
4166 !      include 'COMMON.CONTACTS'
4167 !      include 'COMMON.TORSION'
4168 !      include 'COMMON.VECTORS'
4169 !      include 'COMMON.FFIELD'
4170 !      include 'COMMON.CONTROL'
4171       real(kind=8),dimension(3) :: ggg
4172       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4173         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4174       real(kind=8),dimension(2) :: auxvec,auxvec1
4175 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4176       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4177 !el      integer :: num_conti,j1,j2
4178 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4179 !el        dz_normi,xmedi,ymedi,zmedi
4180
4181 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4182 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4183 !el         num_conti,j1,j2
4184 !el local variables
4185       integer :: i,j,l,k,ilist,iresshield
4186       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4187
4188       j=i+2
4189 !      write (iout,*) "eturn3",i,j,j1,j2
4190           zj=(c(3,j)+c(3,j+1))/2.0d0
4191           zj=mod(zj,boxzsize)
4192           if (zj.lt.0) zj=zj+boxzsize
4193           if ((zj.lt.0)) write (*,*) "CHUJ"
4194        if ((zj.gt.bordlipbot)  &
4195         .and.(zj.lt.bordliptop)) then
4196 !C the energy transfer exist
4197         if (zj.lt.buflipbot) then
4198 !C what fraction I am in
4199          fracinbuf=1.0d0-     &
4200              ((zj-bordlipbot)/lipbufthick)
4201 !C lipbufthick is thickenes of lipid buffore
4202          sslipj=sscalelip(fracinbuf)
4203          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4204         elseif (zj.gt.bufliptop) then
4205          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4206          sslipj=sscalelip(fracinbuf)
4207          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4208         else
4209          sslipj=1.0d0
4210          ssgradlipj=0.0
4211         endif
4212        else
4213          sslipj=0.0d0
4214          ssgradlipj=0.0
4215        endif
4216
4217       a_temp(1,1)=a22
4218       a_temp(1,2)=a23
4219       a_temp(2,1)=a32
4220       a_temp(2,2)=a33
4221 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4222 !
4223 !               Third-order contributions
4224 !
4225 !                 (i+2)o----(i+3)
4226 !                      | |
4227 !                      | |
4228 !                 (i+1)o----i
4229 !
4230 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4231 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4232         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4233         call transpose2(auxmat(1,1),auxmat1(1,1))
4234         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4235         if (shield_mode.eq.0) then
4236         fac_shield(i)=1.0d0
4237         fac_shield(j)=1.0d0
4238         endif
4239
4240         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4241          *fac_shield(i)*fac_shield(j)  &
4242          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4243         eello_t3= &
4244         0.5d0*(pizda(1,1)+pizda(2,2)) &
4245         *fac_shield(i)*fac_shield(j)
4246
4247         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4248                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4249           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4250        (shield_mode.gt.0)) then
4251 !C          print *,i,j
4252
4253           do ilist=1,ishield_list(i)
4254            iresshield=shield_list(ilist,i)
4255            do k=1,3
4256            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4257            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4258                    rlocshield &
4259            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4260             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4261              +rlocshield
4262            enddo
4263           enddo
4264           do ilist=1,ishield_list(j)
4265            iresshield=shield_list(ilist,j)
4266            do k=1,3
4267            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4268            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4269                    rlocshield &
4270            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4271            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4272                   +rlocshield
4273
4274            enddo
4275           enddo
4276
4277           do k=1,3
4278             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4279                    grad_shield(k,i)*eello_t3/fac_shield(i)
4280             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4281                    grad_shield(k,j)*eello_t3/fac_shield(j)
4282             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4283                    grad_shield(k,i)*eello_t3/fac_shield(i)
4284             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4285                    grad_shield(k,j)*eello_t3/fac_shield(j)
4286            enddo
4287            endif
4288
4289 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4290 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4291 !d     &    ' eello_turn3_num',4*eello_turn3_num
4292 ! Derivatives in gamma(i)
4293         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4294         call transpose2(auxmat2(1,1),auxmat3(1,1))
4295         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4296         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4297           *fac_shield(i)*fac_shield(j)        &
4298           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4299 ! Derivatives in gamma(i+1)
4300         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4301         call transpose2(auxmat2(1,1),auxmat3(1,1))
4302         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4303         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4304           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4305           *fac_shield(i)*fac_shield(j)        &
4306           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4307
4308 ! Cartesian derivatives
4309         do l=1,3
4310 !            ghalf1=0.5d0*agg(l,1)
4311 !            ghalf2=0.5d0*agg(l,2)
4312 !            ghalf3=0.5d0*agg(l,3)
4313 !            ghalf4=0.5d0*agg(l,4)
4314           a_temp(1,1)=aggi(l,1)!+ghalf1
4315           a_temp(1,2)=aggi(l,2)!+ghalf2
4316           a_temp(2,1)=aggi(l,3)!+ghalf3
4317           a_temp(2,2)=aggi(l,4)!+ghalf4
4318           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4319           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4320             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4321           *fac_shield(i)*fac_shield(j)      &
4322           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4323
4324           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4325           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4326           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4327           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4328           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4329           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4330             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4331           *fac_shield(i)*fac_shield(j)        &
4332           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4333
4334           a_temp(1,1)=aggj(l,1)!+ghalf1
4335           a_temp(1,2)=aggj(l,2)!+ghalf2
4336           a_temp(2,1)=aggj(l,3)!+ghalf3
4337           a_temp(2,2)=aggj(l,4)!+ghalf4
4338           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4339           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4340             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4341           *fac_shield(i)*fac_shield(j)      &
4342           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4343
4344           a_temp(1,1)=aggj1(l,1)
4345           a_temp(1,2)=aggj1(l,2)
4346           a_temp(2,1)=aggj1(l,3)
4347           a_temp(2,2)=aggj1(l,4)
4348           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4349           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4350             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4351           *fac_shield(i)*fac_shield(j)        &
4352           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4353         enddo
4354          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4355           ssgradlipi*eello_t3/4.0d0*lipscale
4356          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4357           ssgradlipj*eello_t3/4.0d0*lipscale
4358          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4359           ssgradlipi*eello_t3/4.0d0*lipscale
4360          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4361           ssgradlipj*eello_t3/4.0d0*lipscale
4362
4363       return
4364       end subroutine eturn3
4365 !-----------------------------------------------------------------------------
4366       subroutine eturn4(i,eello_turn4)
4367 ! Third- and fourth-order contributions from turns
4368
4369       use comm_locel
4370 !      implicit real*8 (a-h,o-z)
4371 !      include 'DIMENSIONS'
4372 !      include 'COMMON.IOUNITS'
4373 !      include 'COMMON.GEO'
4374 !      include 'COMMON.VAR'
4375 !      include 'COMMON.LOCAL'
4376 !      include 'COMMON.CHAIN'
4377 !      include 'COMMON.DERIV'
4378 !      include 'COMMON.INTERACT'
4379 !      include 'COMMON.CONTACTS'
4380 !      include 'COMMON.TORSION'
4381 !      include 'COMMON.VECTORS'
4382 !      include 'COMMON.FFIELD'
4383 !      include 'COMMON.CONTROL'
4384       real(kind=8),dimension(3) :: ggg
4385       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4386         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4387       real(kind=8),dimension(2) :: auxvec,auxvec1
4388 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4389       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4390 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4391 !el        dz_normi,xmedi,ymedi,zmedi
4392 !el      integer :: num_conti,j1,j2
4393 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4394 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4395 !el          num_conti,j1,j2
4396 !el local variables
4397       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4398       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4399          rlocshield
4400
4401       j=i+3
4402 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4403 !
4404 !               Fourth-order contributions
4405 !
4406 !                 (i+3)o----(i+4)
4407 !                     /  |
4408 !               (i+2)o   |
4409 !                     \  |
4410 !                 (i+1)o----i
4411 !
4412 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4413 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4414 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4415           zj=(c(3,j)+c(3,j+1))/2.0d0
4416           zj=mod(zj,boxzsize)
4417           if (zj.lt.0) zj=zj+boxzsize
4418        if ((zj.gt.bordlipbot)  &
4419         .and.(zj.lt.bordliptop)) then
4420 !C the energy transfer exist
4421         if (zj.lt.buflipbot) then
4422 !C what fraction I am in
4423          fracinbuf=1.0d0-     &
4424              ((zj-bordlipbot)/lipbufthick)
4425 !C lipbufthick is thickenes of lipid buffore
4426          sslipj=sscalelip(fracinbuf)
4427          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4428         elseif (zj.gt.bufliptop) then
4429          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4430          sslipj=sscalelip(fracinbuf)
4431          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4432         else
4433          sslipj=1.0d0
4434          ssgradlipj=0.0
4435         endif
4436        else
4437          sslipj=0.0d0
4438          ssgradlipj=0.0
4439        endif
4440
4441         a_temp(1,1)=a22
4442         a_temp(1,2)=a23
4443         a_temp(2,1)=a32
4444         a_temp(2,2)=a33
4445         iti1=itortyp(itype(i+1,1))
4446         iti2=itortyp(itype(i+2,1))
4447         iti3=itortyp(itype(i+3,1))
4448 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4449         call transpose2(EUg(1,1,i+1),e1t(1,1))
4450         call transpose2(Eug(1,1,i+2),e2t(1,1))
4451         call transpose2(Eug(1,1,i+3),e3t(1,1))
4452         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4453         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4454         s1=scalar2(b1(1,iti2),auxvec(1))
4455         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4456         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4457         s2=scalar2(b1(1,iti1),auxvec(1))
4458         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4459         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4460         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4461         if (shield_mode.eq.0) then
4462         fac_shield(i)=1.0
4463         fac_shield(j)=1.0
4464         endif
4465
4466         eello_turn4=eello_turn4-(s1+s2+s3) &
4467         *fac_shield(i)*fac_shield(j)       &
4468         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4469         eello_t4=-(s1+s2+s3)  &
4470           *fac_shield(i)*fac_shield(j)
4471 !C Now derivative over shield:
4472           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4473          (shield_mode.gt.0)) then
4474 !C          print *,i,j
4475
4476           do ilist=1,ishield_list(i)
4477            iresshield=shield_list(ilist,i)
4478            do k=1,3
4479            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4480            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4481                    rlocshield &
4482             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4483             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4484            +rlocshield
4485            enddo
4486           enddo
4487           do ilist=1,ishield_list(j)
4488            iresshield=shield_list(ilist,j)
4489            do k=1,3
4490            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4491            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4492                    rlocshield  &
4493            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4494            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4495                   +rlocshield
4496
4497            enddo
4498           enddo
4499
4500           do k=1,3
4501             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4502                    grad_shield(k,i)*eello_t4/fac_shield(i)
4503             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4504                    grad_shield(k,j)*eello_t4/fac_shield(j)
4505             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4506                    grad_shield(k,i)*eello_t4/fac_shield(i)
4507             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4508                    grad_shield(k,j)*eello_t4/fac_shield(j)
4509            enddo
4510            endif
4511
4512         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4513            'eturn4',i,j,-(s1+s2+s3)
4514 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4515 !d     &    ' eello_turn4_num',8*eello_turn4_num
4516 ! Derivatives in gamma(i)
4517         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4518         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4519         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4520         s1=scalar2(b1(1,iti2),auxvec(1))
4521         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4522         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4523         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4524        *fac_shield(i)*fac_shield(j)  &
4525        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4526
4527 ! Derivatives in gamma(i+1)
4528         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4529         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4530         s2=scalar2(b1(1,iti1),auxvec(1))
4531         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4532         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4533         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4534         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4535        *fac_shield(i)*fac_shield(j)  &
4536        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4537
4538 ! Derivatives in gamma(i+2)
4539         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4540         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4541         s1=scalar2(b1(1,iti2),auxvec(1))
4542         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4543         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4544         s2=scalar2(b1(1,iti1),auxvec(1))
4545         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4546         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4547         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4548         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4549        *fac_shield(i)*fac_shield(j)  &
4550        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4551
4552 ! Cartesian derivatives
4553 ! Derivatives of this turn contributions in DC(i+2)
4554         if (j.lt.nres-1) then
4555           do l=1,3
4556             a_temp(1,1)=agg(l,1)
4557             a_temp(1,2)=agg(l,2)
4558             a_temp(2,1)=agg(l,3)
4559             a_temp(2,2)=agg(l,4)
4560             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4561             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4562             s1=scalar2(b1(1,iti2),auxvec(1))
4563             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4564             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4565             s2=scalar2(b1(1,iti1),auxvec(1))
4566             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4567             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4568             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4569             ggg(l)=-(s1+s2+s3)
4570             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4571        *fac_shield(i)*fac_shield(j)  &
4572        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4573
4574           enddo
4575         endif
4576 ! Remaining derivatives of this turn contribution
4577         do l=1,3
4578           a_temp(1,1)=aggi(l,1)
4579           a_temp(1,2)=aggi(l,2)
4580           a_temp(2,1)=aggi(l,3)
4581           a_temp(2,2)=aggi(l,4)
4582           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4583           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4584           s1=scalar2(b1(1,iti2),auxvec(1))
4585           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4586           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4587           s2=scalar2(b1(1,iti1),auxvec(1))
4588           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4589           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4590           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4591           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4592          *fac_shield(i)*fac_shield(j)  &
4593          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4594
4595
4596           a_temp(1,1)=aggi1(l,1)
4597           a_temp(1,2)=aggi1(l,2)
4598           a_temp(2,1)=aggi1(l,3)
4599           a_temp(2,2)=aggi1(l,4)
4600           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4601           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4602           s1=scalar2(b1(1,iti2),auxvec(1))
4603           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4604           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4605           s2=scalar2(b1(1,iti1),auxvec(1))
4606           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4607           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4608           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4609           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4610          *fac_shield(i)*fac_shield(j)  &
4611          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4612
4613
4614           a_temp(1,1)=aggj(l,1)
4615           a_temp(1,2)=aggj(l,2)
4616           a_temp(2,1)=aggj(l,3)
4617           a_temp(2,2)=aggj(l,4)
4618           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4619           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4620           s1=scalar2(b1(1,iti2),auxvec(1))
4621           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4622           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4623           s2=scalar2(b1(1,iti1),auxvec(1))
4624           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4625           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4626           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4627           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4628          *fac_shield(i)*fac_shield(j)  &
4629          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4630
4631
4632           a_temp(1,1)=aggj1(l,1)
4633           a_temp(1,2)=aggj1(l,2)
4634           a_temp(2,1)=aggj1(l,3)
4635           a_temp(2,2)=aggj1(l,4)
4636           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4637           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4638           s1=scalar2(b1(1,iti2),auxvec(1))
4639           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4640           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4641           s2=scalar2(b1(1,iti1),auxvec(1))
4642           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4643           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4644           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4645 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4646           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4647          *fac_shield(i)*fac_shield(j)  &
4648          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4649
4650         enddo
4651          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4652           ssgradlipi*eello_t4/4.0d0*lipscale
4653          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4654           ssgradlipj*eello_t4/4.0d0*lipscale
4655          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4656           ssgradlipi*eello_t4/4.0d0*lipscale
4657          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4658           ssgradlipj*eello_t4/4.0d0*lipscale
4659
4660       return
4661       end subroutine eturn4
4662 !-----------------------------------------------------------------------------
4663       subroutine unormderiv(u,ugrad,unorm,ungrad)
4664 ! This subroutine computes the derivatives of a normalized vector u, given
4665 ! the derivatives computed without normalization conditions, ugrad. Returns
4666 ! ungrad.
4667 !      implicit none
4668       real(kind=8),dimension(3) :: u,vec
4669       real(kind=8),dimension(3,3) ::ugrad,ungrad
4670       real(kind=8) :: unorm     !,scalar
4671       integer :: i,j
4672 !      write (2,*) 'ugrad',ugrad
4673 !      write (2,*) 'u',u
4674       do i=1,3
4675         vec(i)=scalar(ugrad(1,i),u(1))
4676       enddo
4677 !      write (2,*) 'vec',vec
4678       do i=1,3
4679         do j=1,3
4680           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4681         enddo
4682       enddo
4683 !      write (2,*) 'ungrad',ungrad
4684       return
4685       end subroutine unormderiv
4686 !-----------------------------------------------------------------------------
4687       subroutine escp_soft_sphere(evdw2,evdw2_14)
4688 !
4689 ! This subroutine calculates the excluded-volume interaction energy between
4690 ! peptide-group centers and side chains and its gradient in virtual-bond and
4691 ! side-chain vectors.
4692 !
4693 !      implicit real*8 (a-h,o-z)
4694 !      include 'DIMENSIONS'
4695 !      include 'COMMON.GEO'
4696 !      include 'COMMON.VAR'
4697 !      include 'COMMON.LOCAL'
4698 !      include 'COMMON.CHAIN'
4699 !      include 'COMMON.DERIV'
4700 !      include 'COMMON.INTERACT'
4701 !      include 'COMMON.FFIELD'
4702 !      include 'COMMON.IOUNITS'
4703 !      include 'COMMON.CONTROL'
4704       real(kind=8),dimension(3) :: ggg
4705 !el local variables
4706       integer :: i,iint,j,k,iteli,itypj
4707       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4708                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4709
4710       evdw2=0.0D0
4711       evdw2_14=0.0d0
4712       r0_scp=4.5d0
4713 !d    print '(a)','Enter ESCP'
4714 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4715       do i=iatscp_s,iatscp_e
4716         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4717         iteli=itel(i)
4718         xi=0.5D0*(c(1,i)+c(1,i+1))
4719         yi=0.5D0*(c(2,i)+c(2,i+1))
4720         zi=0.5D0*(c(3,i)+c(3,i+1))
4721
4722         do iint=1,nscp_gr(i)
4723
4724         do j=iscpstart(i,iint),iscpend(i,iint)
4725           if (itype(j,1).eq.ntyp1) cycle
4726           itypj=iabs(itype(j,1))
4727 ! Uncomment following three lines for SC-p interactions
4728 !         xj=c(1,nres+j)-xi
4729 !         yj=c(2,nres+j)-yi
4730 !         zj=c(3,nres+j)-zi
4731 ! Uncomment following three lines for Ca-p interactions
4732           xj=c(1,j)-xi
4733           yj=c(2,j)-yi
4734           zj=c(3,j)-zi
4735           rij=xj*xj+yj*yj+zj*zj
4736           r0ij=r0_scp
4737           r0ijsq=r0ij*r0ij
4738           if (rij.lt.r0ijsq) then
4739             evdwij=0.25d0*(rij-r0ijsq)**2
4740             fac=rij-r0ijsq
4741           else
4742             evdwij=0.0d0
4743             fac=0.0d0
4744           endif
4745           evdw2=evdw2+evdwij
4746 !
4747 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4748 !
4749           ggg(1)=xj*fac
4750           ggg(2)=yj*fac
4751           ggg(3)=zj*fac
4752 !grad          if (j.lt.i) then
4753 !d          write (iout,*) 'j<i'
4754 ! Uncomment following three lines for SC-p interactions
4755 !           do k=1,3
4756 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4757 !           enddo
4758 !grad          else
4759 !d          write (iout,*) 'j>i'
4760 !grad            do k=1,3
4761 !grad              ggg(k)=-ggg(k)
4762 ! Uncomment following line for SC-p interactions
4763 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4764 !grad            enddo
4765 !grad          endif
4766 !grad          do k=1,3
4767 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4768 !grad          enddo
4769 !grad          kstart=min0(i+1,j)
4770 !grad          kend=max0(i-1,j-1)
4771 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4772 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4773 !grad          do k=kstart,kend
4774 !grad            do l=1,3
4775 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4776 !grad            enddo
4777 !grad          enddo
4778           do k=1,3
4779             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4780             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4781           enddo
4782         enddo
4783
4784         enddo ! iint
4785       enddo ! i
4786       return
4787       end subroutine escp_soft_sphere
4788 !-----------------------------------------------------------------------------
4789       subroutine escp(evdw2,evdw2_14)
4790 !
4791 ! This subroutine calculates the excluded-volume interaction energy between
4792 ! peptide-group centers and side chains and its gradient in virtual-bond and
4793 ! side-chain vectors.
4794 !
4795 !      implicit real*8 (a-h,o-z)
4796 !      include 'DIMENSIONS'
4797 !      include 'COMMON.GEO'
4798 !      include 'COMMON.VAR'
4799 !      include 'COMMON.LOCAL'
4800 !      include 'COMMON.CHAIN'
4801 !      include 'COMMON.DERIV'
4802 !      include 'COMMON.INTERACT'
4803 !      include 'COMMON.FFIELD'
4804 !      include 'COMMON.IOUNITS'
4805 !      include 'COMMON.CONTROL'
4806       real(kind=8),dimension(3) :: ggg
4807 !el local variables
4808       integer :: i,iint,j,k,iteli,itypj,subchap
4809       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4810                    e1,e2,evdwij,rij
4811       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4812                     dist_temp, dist_init
4813       integer xshift,yshift,zshift
4814
4815       evdw2=0.0D0
4816       evdw2_14=0.0d0
4817 !d    print '(a)','Enter ESCP'
4818 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4819       do i=iatscp_s,iatscp_e
4820         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4821         iteli=itel(i)
4822         xi=0.5D0*(c(1,i)+c(1,i+1))
4823         yi=0.5D0*(c(2,i)+c(2,i+1))
4824         zi=0.5D0*(c(3,i)+c(3,i+1))
4825           xi=mod(xi,boxxsize)
4826           if (xi.lt.0) xi=xi+boxxsize
4827           yi=mod(yi,boxysize)
4828           if (yi.lt.0) yi=yi+boxysize
4829           zi=mod(zi,boxzsize)
4830           if (zi.lt.0) zi=zi+boxzsize
4831
4832         do iint=1,nscp_gr(i)
4833
4834         do j=iscpstart(i,iint),iscpend(i,iint)
4835           itypj=iabs(itype(j,1))
4836           if (itypj.eq.ntyp1) cycle
4837 ! Uncomment following three lines for SC-p interactions
4838 !         xj=c(1,nres+j)-xi
4839 !         yj=c(2,nres+j)-yi
4840 !         zj=c(3,nres+j)-zi
4841 ! Uncomment following three lines for Ca-p interactions
4842 !          xj=c(1,j)-xi
4843 !          yj=c(2,j)-yi
4844 !          zj=c(3,j)-zi
4845           xj=c(1,j)
4846           yj=c(2,j)
4847           zj=c(3,j)
4848           xj=mod(xj,boxxsize)
4849           if (xj.lt.0) xj=xj+boxxsize
4850           yj=mod(yj,boxysize)
4851           if (yj.lt.0) yj=yj+boxysize
4852           zj=mod(zj,boxzsize)
4853           if (zj.lt.0) zj=zj+boxzsize
4854       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4855       xj_safe=xj
4856       yj_safe=yj
4857       zj_safe=zj
4858       subchap=0
4859       do xshift=-1,1
4860       do yshift=-1,1
4861       do zshift=-1,1
4862           xj=xj_safe+xshift*boxxsize
4863           yj=yj_safe+yshift*boxysize
4864           zj=zj_safe+zshift*boxzsize
4865           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4866           if(dist_temp.lt.dist_init) then
4867             dist_init=dist_temp
4868             xj_temp=xj
4869             yj_temp=yj
4870             zj_temp=zj
4871             subchap=1
4872           endif
4873        enddo
4874        enddo
4875        enddo
4876        if (subchap.eq.1) then
4877           xj=xj_temp-xi
4878           yj=yj_temp-yi
4879           zj=zj_temp-zi
4880        else
4881           xj=xj_safe-xi
4882           yj=yj_safe-yi
4883           zj=zj_safe-zi
4884        endif
4885
4886           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4887           rij=dsqrt(1.0d0/rrij)
4888             sss_ele_cut=sscale_ele(rij)
4889             sss_ele_grad=sscagrad_ele(rij)
4890 !            print *,sss_ele_cut,sss_ele_grad,&
4891 !            (rij),r_cut_ele,rlamb_ele
4892             if (sss_ele_cut.le.0.0) cycle
4893           fac=rrij**expon2
4894           e1=fac*fac*aad(itypj,iteli)
4895           e2=fac*bad(itypj,iteli)
4896           if (iabs(j-i) .le. 2) then
4897             e1=scal14*e1
4898             e2=scal14*e2
4899             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
4900           endif
4901           evdwij=e1+e2
4902           evdw2=evdw2+evdwij*sss_ele_cut
4903 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
4904 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
4905           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4906              'evdw2',i,j,evdwij
4907 !
4908 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4909 !
4910           fac=-(evdwij+e1)*rrij*sss_ele_cut
4911           fac=fac+evdwij*sss_ele_grad/rij/expon
4912           ggg(1)=xj*fac
4913           ggg(2)=yj*fac
4914           ggg(3)=zj*fac
4915 !grad          if (j.lt.i) then
4916 !d          write (iout,*) 'j<i'
4917 ! Uncomment following three lines for SC-p interactions
4918 !           do k=1,3
4919 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4920 !           enddo
4921 !grad          else
4922 !d          write (iout,*) 'j>i'
4923 !grad            do k=1,3
4924 !grad              ggg(k)=-ggg(k)
4925 ! Uncomment following line for SC-p interactions
4926 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4927 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4928 !grad            enddo
4929 !grad          endif
4930 !grad          do k=1,3
4931 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4932 !grad          enddo
4933 !grad          kstart=min0(i+1,j)
4934 !grad          kend=max0(i-1,j-1)
4935 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4936 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4937 !grad          do k=kstart,kend
4938 !grad            do l=1,3
4939 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4940 !grad            enddo
4941 !grad          enddo
4942           do k=1,3
4943             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4944             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4945           enddo
4946         enddo
4947
4948         enddo ! iint
4949       enddo ! i
4950       do i=1,nct
4951         do j=1,3
4952           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4953           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4954           gradx_scp(j,i)=expon*gradx_scp(j,i)
4955         enddo
4956       enddo
4957 !******************************************************************************
4958 !
4959 !                              N O T E !!!
4960 !
4961 ! To save time the factor EXPON has been extracted from ALL components
4962 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
4963 ! use!
4964 !
4965 !******************************************************************************
4966       return
4967       end subroutine escp
4968 !-----------------------------------------------------------------------------
4969       subroutine edis(ehpb)
4970 !
4971 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4972 !
4973 !      implicit real*8 (a-h,o-z)
4974 !      include 'DIMENSIONS'
4975 !      include 'COMMON.SBRIDGE'
4976 !      include 'COMMON.CHAIN'
4977 !      include 'COMMON.DERIV'
4978 !      include 'COMMON.VAR'
4979 !      include 'COMMON.INTERACT'
4980 !      include 'COMMON.IOUNITS'
4981       real(kind=8),dimension(3) :: ggg
4982 !el local variables
4983       integer :: i,j,ii,jj,iii,jjj,k
4984       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
4985
4986       ehpb=0.0D0
4987 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4988 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
4989       if (link_end.eq.0) return
4990       do i=link_start,link_end
4991 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4992 ! CA-CA distance used in regularization of structure.
4993         ii=ihpb(i)
4994         jj=jhpb(i)
4995 ! iii and jjj point to the residues for which the distance is assigned.
4996         if (ii.gt.nres) then
4997           iii=ii-nres
4998           jjj=jj-nres
4999         else
5000           iii=ii
5001           jjj=jj
5002         endif
5003 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5004 !     &    dhpb(i),dhpb1(i),forcon(i)
5005 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5006 !    distance and angle dependent SS bond potential.
5007 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5008 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5009         if (.not.dyn_ss .and. i.le.nss) then
5010 ! 15/02/13 CC dynamic SSbond - additional check
5011          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5012         iabs(itype(jjj,1)).eq.1) then
5013           call ssbond_ene(iii,jjj,eij)
5014           ehpb=ehpb+2*eij
5015 !d          write (iout,*) "eij",eij
5016          endif
5017         else if (ii.gt.nres .and. jj.gt.nres) then
5018 !c Restraints from contact prediction
5019           dd=dist(ii,jj)
5020           if (constr_dist.eq.11) then
5021             ehpb=ehpb+fordepth(i)**4.0d0 &
5022                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5023             fac=fordepth(i)**4.0d0 &
5024                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5025           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5026             ehpb,fordepth(i),dd
5027            else
5028           if (dhpb1(i).gt.0.0d0) then
5029             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5030             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5031 !c            write (iout,*) "beta nmr",
5032 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5033           else
5034             dd=dist(ii,jj)
5035             rdis=dd-dhpb(i)
5036 !C Get the force constant corresponding to this distance.
5037             waga=forcon(i)
5038 !C Calculate the contribution to energy.
5039             ehpb=ehpb+waga*rdis*rdis
5040 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5041 !C
5042 !C Evaluate gradient.
5043 !C
5044             fac=waga*rdis/dd
5045           endif
5046           endif
5047           do j=1,3
5048             ggg(j)=fac*(c(j,jj)-c(j,ii))
5049           enddo
5050           do j=1,3
5051             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5052             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5053           enddo
5054           do k=1,3
5055             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5056             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5057           enddo
5058         else
5059           dd=dist(ii,jj)
5060           if (constr_dist.eq.11) then
5061             ehpb=ehpb+fordepth(i)**4.0d0 &
5062                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5063             fac=fordepth(i)**4.0d0 &
5064                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5065           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5066          ehpb,fordepth(i),dd
5067            else
5068           if (dhpb1(i).gt.0.0d0) then
5069             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5070             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5071 !c            write (iout,*) "alph nmr",
5072 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5073           else
5074             rdis=dd-dhpb(i)
5075 !C Get the force constant corresponding to this distance.
5076             waga=forcon(i)
5077 !C Calculate the contribution to energy.
5078             ehpb=ehpb+waga*rdis*rdis
5079 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5080 !C
5081 !C Evaluate gradient.
5082 !C
5083             fac=waga*rdis/dd
5084           endif
5085           endif
5086
5087             do j=1,3
5088               ggg(j)=fac*(c(j,jj)-c(j,ii))
5089             enddo
5090 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5091 !C If this is a SC-SC distance, we need to calculate the contributions to the
5092 !C Cartesian gradient in the SC vectors (ghpbx).
5093           if (iii.lt.ii) then
5094           do j=1,3
5095             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5096             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5097           enddo
5098           endif
5099 !cgrad        do j=iii,jjj-1
5100 !cgrad          do k=1,3
5101 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5102 !cgrad          enddo
5103 !cgrad        enddo
5104           do k=1,3
5105             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5106             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5107           enddo
5108         endif
5109       enddo
5110       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5111
5112       return
5113       end subroutine edis
5114 !-----------------------------------------------------------------------------
5115       subroutine ssbond_ene(i,j,eij)
5116 !
5117 ! Calculate the distance and angle dependent SS-bond potential energy
5118 ! using a free-energy function derived based on RHF/6-31G** ab initio
5119 ! calculations of diethyl disulfide.
5120 !
5121 ! A. Liwo and U. Kozlowska, 11/24/03
5122 !
5123 !      implicit real*8 (a-h,o-z)
5124 !      include 'DIMENSIONS'
5125 !      include 'COMMON.SBRIDGE'
5126 !      include 'COMMON.CHAIN'
5127 !      include 'COMMON.DERIV'
5128 !      include 'COMMON.LOCAL'
5129 !      include 'COMMON.INTERACT'
5130 !      include 'COMMON.VAR'
5131 !      include 'COMMON.IOUNITS'
5132       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5133 !el local variables
5134       integer :: i,j,itypi,itypj,k
5135       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5136                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5137                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5138                    cosphi,ggk
5139
5140       itypi=iabs(itype(i,1))
5141       xi=c(1,nres+i)
5142       yi=c(2,nres+i)
5143       zi=c(3,nres+i)
5144       dxi=dc_norm(1,nres+i)
5145       dyi=dc_norm(2,nres+i)
5146       dzi=dc_norm(3,nres+i)
5147 !      dsci_inv=dsc_inv(itypi)
5148       dsci_inv=vbld_inv(nres+i)
5149       itypj=iabs(itype(j,1))
5150 !      dscj_inv=dsc_inv(itypj)
5151       dscj_inv=vbld_inv(nres+j)
5152       xj=c(1,nres+j)-xi
5153       yj=c(2,nres+j)-yi
5154       zj=c(3,nres+j)-zi
5155       dxj=dc_norm(1,nres+j)
5156       dyj=dc_norm(2,nres+j)
5157       dzj=dc_norm(3,nres+j)
5158       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5159       rij=dsqrt(rrij)
5160       erij(1)=xj*rij
5161       erij(2)=yj*rij
5162       erij(3)=zj*rij
5163       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5164       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5165       om12=dxi*dxj+dyi*dyj+dzi*dzj
5166       do k=1,3
5167         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5168         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5169       enddo
5170       rij=1.0d0/rij
5171       deltad=rij-d0cm
5172       deltat1=1.0d0-om1
5173       deltat2=1.0d0+om2
5174       deltat12=om2-om1+2.0d0
5175       cosphi=om12-om1*om2
5176       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5177         +akct*deltad*deltat12 &
5178         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5179 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5180 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5181 !     &  " deltat12",deltat12," eij",eij
5182       ed=2*akcm*deltad+akct*deltat12
5183       pom1=akct*deltad
5184       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5185       eom1=-2*akth*deltat1-pom1-om2*pom2
5186       eom2= 2*akth*deltat2+pom1-om1*pom2
5187       eom12=pom2
5188       do k=1,3
5189         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5190         ghpbx(k,i)=ghpbx(k,i)-ggk &
5191                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5192                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5193         ghpbx(k,j)=ghpbx(k,j)+ggk &
5194                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5195                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5196         ghpbc(k,i)=ghpbc(k,i)-ggk
5197         ghpbc(k,j)=ghpbc(k,j)+ggk
5198       enddo
5199 !
5200 ! Calculate the components of the gradient in DC and X
5201 !
5202 !grad      do k=i,j-1
5203 !grad        do l=1,3
5204 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5205 !grad        enddo
5206 !grad      enddo
5207       return
5208       end subroutine ssbond_ene
5209 !-----------------------------------------------------------------------------
5210       subroutine ebond(estr)
5211 !
5212 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5213 !
5214 !      implicit real*8 (a-h,o-z)
5215 !      include 'DIMENSIONS'
5216 !      include 'COMMON.LOCAL'
5217 !      include 'COMMON.GEO'
5218 !      include 'COMMON.INTERACT'
5219 !      include 'COMMON.DERIV'
5220 !      include 'COMMON.VAR'
5221 !      include 'COMMON.CHAIN'
5222 !      include 'COMMON.IOUNITS'
5223 !      include 'COMMON.NAMES'
5224 !      include 'COMMON.FFIELD'
5225 !      include 'COMMON.CONTROL'
5226 !      include 'COMMON.SETUP'
5227       real(kind=8),dimension(3) :: u,ud
5228 !el local variables
5229       integer :: i,j,iti,nbi,k
5230       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5231                    uprod1,uprod2
5232
5233       estr=0.0d0
5234       estr1=0.0d0
5235 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5236 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5237
5238       do i=ibondp_start,ibondp_end
5239         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5240         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5241 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5242 !C          do j=1,3
5243 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5244 !C            *dc(j,i-1)/vbld(i)
5245 !C          enddo
5246 !C          if (energy_dec) write(iout,*) &
5247 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5248         diff = vbld(i)-vbldpDUM
5249         else
5250         diff = vbld(i)-vbldp0
5251         endif
5252         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5253            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5254         estr=estr+diff*diff
5255         do j=1,3
5256           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5257         enddo
5258 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5259 !        endif
5260       enddo
5261       estr=0.5d0*AKP*estr+estr1
5262 !      print *,"estr_bb",estr,AKP
5263 !
5264 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5265 !
5266       do i=ibond_start,ibond_end
5267         iti=iabs(itype(i,1))
5268         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5269         if (iti.ne.10 .and. iti.ne.ntyp1) then
5270           nbi=nbondterm(iti)
5271           if (nbi.eq.1) then
5272             diff=vbld(i+nres)-vbldsc0(1,iti)
5273             if (energy_dec) write (iout,*) &
5274             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5275             AKSC(1,iti),AKSC(1,iti)*diff*diff
5276             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5277 !            print *,"estr_sc",estr
5278             do j=1,3
5279               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5280             enddo
5281           else
5282             do j=1,nbi
5283               diff=vbld(i+nres)-vbldsc0(j,iti)
5284               ud(j)=aksc(j,iti)*diff
5285               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5286             enddo
5287             uprod=u(1)
5288             do j=2,nbi
5289               uprod=uprod*u(j)
5290             enddo
5291             usum=0.0d0
5292             usumsqder=0.0d0
5293             do j=1,nbi
5294               uprod1=1.0d0
5295               uprod2=1.0d0
5296               do k=1,nbi
5297                 if (k.ne.j) then
5298                   uprod1=uprod1*u(k)
5299                   uprod2=uprod2*u(k)*u(k)
5300                 endif
5301               enddo
5302               usum=usum+uprod1
5303               usumsqder=usumsqder+ud(j)*uprod2
5304             enddo
5305             estr=estr+uprod/usum
5306 !            print *,"estr_sc",estr,i
5307
5308              if (energy_dec) write (iout,*) &
5309             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5310             AKSC(1,iti),uprod/usum
5311             do j=1,3
5312              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5313             enddo
5314           endif
5315         endif
5316       enddo
5317       return
5318       end subroutine ebond
5319 #ifdef CRYST_THETA
5320 !-----------------------------------------------------------------------------
5321       subroutine ebend(etheta)
5322 !
5323 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5324 ! angles gamma and its derivatives in consecutive thetas and gammas.
5325 !
5326       use comm_calcthet
5327 !      implicit real*8 (a-h,o-z)
5328 !      include 'DIMENSIONS'
5329 !      include 'COMMON.LOCAL'
5330 !      include 'COMMON.GEO'
5331 !      include 'COMMON.INTERACT'
5332 !      include 'COMMON.DERIV'
5333 !      include 'COMMON.VAR'
5334 !      include 'COMMON.CHAIN'
5335 !      include 'COMMON.IOUNITS'
5336 !      include 'COMMON.NAMES'
5337 !      include 'COMMON.FFIELD'
5338 !      include 'COMMON.CONTROL'
5339 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5340 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5341 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5342 !el      integer :: it
5343 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5344 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5345 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5346 !el local variables
5347       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5348        ichir21,ichir22
5349       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5350        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5351        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5352       real(kind=8),dimension(2) :: y,z
5353
5354       delta=0.02d0*pi
5355 !      time11=dexp(-2*time)
5356 !      time12=1.0d0
5357       etheta=0.0D0
5358 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5359       do i=ithet_start,ithet_end
5360         if (itype(i-1,1).eq.ntyp1) cycle
5361 ! Zero the energy function and its derivative at 0 or pi.
5362         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5363         it=itype(i-1,1)
5364         ichir1=isign(1,itype(i-2,1))
5365         ichir2=isign(1,itype(i,1))
5366          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5367          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5368          if (itype(i-1,1).eq.10) then
5369           itype1=isign(10,itype(i-2,1))
5370           ichir11=isign(1,itype(i-2,1))
5371           ichir12=isign(1,itype(i-2,1))
5372           itype2=isign(10,itype(i,1))
5373           ichir21=isign(1,itype(i,1))
5374           ichir22=isign(1,itype(i,1))
5375          endif
5376
5377         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5378 #ifdef OSF
5379           phii=phi(i)
5380           if (phii.ne.phii) phii=150.0
5381 #else
5382           phii=phi(i)
5383 #endif
5384           y(1)=dcos(phii)
5385           y(2)=dsin(phii)
5386         else
5387           y(1)=0.0D0
5388           y(2)=0.0D0
5389         endif
5390         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5391 #ifdef OSF
5392           phii1=phi(i+1)
5393           if (phii1.ne.phii1) phii1=150.0
5394           phii1=pinorm(phii1)
5395           z(1)=cos(phii1)
5396 #else
5397           phii1=phi(i+1)
5398           z(1)=dcos(phii1)
5399 #endif
5400           z(2)=dsin(phii1)
5401         else
5402           z(1)=0.0D0
5403           z(2)=0.0D0
5404         endif
5405 ! Calculate the "mean" value of theta from the part of the distribution
5406 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5407 ! In following comments this theta will be referred to as t_c.
5408         thet_pred_mean=0.0d0
5409         do k=1,2
5410             athetk=athet(k,it,ichir1,ichir2)
5411             bthetk=bthet(k,it,ichir1,ichir2)
5412           if (it.eq.10) then
5413              athetk=athet(k,itype1,ichir11,ichir12)
5414              bthetk=bthet(k,itype2,ichir21,ichir22)
5415           endif
5416          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5417         enddo
5418         dthett=thet_pred_mean*ssd
5419         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5420 ! Derivatives of the "mean" values in gamma1 and gamma2.
5421         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5422                +athet(2,it,ichir1,ichir2)*y(1))*ss
5423         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5424                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5425          if (it.eq.10) then
5426         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5427              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5428         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5429                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5430          endif
5431         if (theta(i).gt.pi-delta) then
5432           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5433                E_tc0)
5434           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5435           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5436           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5437               E_theta)
5438           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5439               E_tc)
5440         else if (theta(i).lt.delta) then
5441           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5442           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5443           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5444               E_theta)
5445           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5446           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5447               E_tc)
5448         else
5449           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5450               E_theta,E_tc)
5451         endif
5452         etheta=etheta+ethetai
5453         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5454             'ebend',i,ethetai
5455         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5456         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5457         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5458       enddo
5459 ! Ufff.... We've done all this!!!
5460       return
5461       end subroutine ebend
5462 !-----------------------------------------------------------------------------
5463       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5464
5465       use comm_calcthet
5466 !      implicit real*8 (a-h,o-z)
5467 !      include 'DIMENSIONS'
5468 !      include 'COMMON.LOCAL'
5469 !      include 'COMMON.IOUNITS'
5470 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5471 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5472 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5473       integer :: i,j,k
5474       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5475 !el      integer :: it
5476 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5477 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5478 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5479 !el local variables
5480       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5481        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5482
5483 ! Calculate the contributions to both Gaussian lobes.
5484 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5485 ! The "polynomial part" of the "standard deviation" of this part of
5486 ! the distribution.
5487         sig=polthet(3,it)
5488         do j=2,0,-1
5489           sig=sig*thet_pred_mean+polthet(j,it)
5490         enddo
5491 ! Derivative of the "interior part" of the "standard deviation of the"
5492 ! gamma-dependent Gaussian lobe in t_c.
5493         sigtc=3*polthet(3,it)
5494         do j=2,1,-1
5495           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5496         enddo
5497         sigtc=sig*sigtc
5498 ! Set the parameters of both Gaussian lobes of the distribution.
5499 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5500         fac=sig*sig+sigc0(it)
5501         sigcsq=fac+fac
5502         sigc=1.0D0/sigcsq
5503 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5504         sigsqtc=-4.0D0*sigcsq*sigtc
5505 !       print *,i,sig,sigtc,sigsqtc
5506 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5507         sigtc=-sigtc/(fac*fac)
5508 ! Following variable is sigma(t_c)**(-2)
5509         sigcsq=sigcsq*sigcsq
5510         sig0i=sig0(it)
5511         sig0inv=1.0D0/sig0i**2
5512         delthec=thetai-thet_pred_mean
5513         delthe0=thetai-theta0i
5514         term1=-0.5D0*sigcsq*delthec*delthec
5515         term2=-0.5D0*sig0inv*delthe0*delthe0
5516 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5517 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5518 ! to the energy (this being the log of the distribution) at the end of energy
5519 ! term evaluation for this virtual-bond angle.
5520         if (term1.gt.term2) then
5521           termm=term1
5522           term2=dexp(term2-termm)
5523           term1=1.0d0
5524         else
5525           termm=term2
5526           term1=dexp(term1-termm)
5527           term2=1.0d0
5528         endif
5529 ! The ratio between the gamma-independent and gamma-dependent lobes of
5530 ! the distribution is a Gaussian function of thet_pred_mean too.
5531         diffak=gthet(2,it)-thet_pred_mean
5532         ratak=diffak/gthet(3,it)**2
5533         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5534 ! Let's differentiate it in thet_pred_mean NOW.
5535         aktc=ak*ratak
5536 ! Now put together the distribution terms to make complete distribution.
5537         termexp=term1+ak*term2
5538         termpre=sigc+ak*sig0i
5539 ! Contribution of the bending energy from this theta is just the -log of
5540 ! the sum of the contributions from the two lobes and the pre-exponential
5541 ! factor. Simple enough, isn't it?
5542         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5543 ! NOW the derivatives!!!
5544 ! 6/6/97 Take into account the deformation.
5545         E_theta=(delthec*sigcsq*term1 &
5546              +ak*delthe0*sig0inv*term2)/termexp
5547         E_tc=((sigtc+aktc*sig0i)/termpre &
5548             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5549              aktc*term2)/termexp)
5550       return
5551       end subroutine theteng
5552 #else
5553 !-----------------------------------------------------------------------------
5554       subroutine ebend(etheta,ethetacnstr)
5555 !
5556 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5557 ! angles gamma and its derivatives in consecutive thetas and gammas.
5558 ! ab initio-derived potentials from
5559 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5560 !
5561 !      implicit real*8 (a-h,o-z)
5562 !      include 'DIMENSIONS'
5563 !      include 'COMMON.LOCAL'
5564 !      include 'COMMON.GEO'
5565 !      include 'COMMON.INTERACT'
5566 !      include 'COMMON.DERIV'
5567 !      include 'COMMON.VAR'
5568 !      include 'COMMON.CHAIN'
5569 !      include 'COMMON.IOUNITS'
5570 !      include 'COMMON.NAMES'
5571 !      include 'COMMON.FFIELD'
5572 !      include 'COMMON.CONTROL'
5573       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5574       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5575       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5576       logical :: lprn=.false., lprn1=.false.
5577 !el local variables
5578       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5579       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5580       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5581 ! local variables for constrains
5582       real(kind=8) :: difi,thetiii
5583        integer itheta
5584
5585       etheta=0.0D0
5586       do i=ithet_start,ithet_end
5587         if (itype(i-1,1).eq.ntyp1) cycle
5588         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5589         if (iabs(itype(i+1,1)).eq.20) iblock=2
5590         if (iabs(itype(i+1,1)).ne.20) iblock=1
5591         dethetai=0.0d0
5592         dephii=0.0d0
5593         dephii1=0.0d0
5594         theti2=0.5d0*theta(i)
5595         ityp2=ithetyp((itype(i-1,1)))
5596         do k=1,nntheterm
5597           coskt(k)=dcos(k*theti2)
5598           sinkt(k)=dsin(k*theti2)
5599         enddo
5600         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5601 #ifdef OSF
5602           phii=phi(i)
5603           if (phii.ne.phii) phii=150.0
5604 #else
5605           phii=phi(i)
5606 #endif
5607           ityp1=ithetyp((itype(i-2,1)))
5608 ! propagation of chirality for glycine type
5609           do k=1,nsingle
5610             cosph1(k)=dcos(k*phii)
5611             sinph1(k)=dsin(k*phii)
5612           enddo
5613         else
5614           phii=0.0d0
5615           ityp1=ithetyp(itype(i-2,1))
5616           do k=1,nsingle
5617             cosph1(k)=0.0d0
5618             sinph1(k)=0.0d0
5619           enddo
5620         endif
5621         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5622 #ifdef OSF
5623           phii1=phi(i+1)
5624           if (phii1.ne.phii1) phii1=150.0
5625           phii1=pinorm(phii1)
5626 #else
5627           phii1=phi(i+1)
5628 #endif
5629           ityp3=ithetyp((itype(i,1)))
5630           do k=1,nsingle
5631             cosph2(k)=dcos(k*phii1)
5632             sinph2(k)=dsin(k*phii1)
5633           enddo
5634         else
5635           phii1=0.0d0
5636           ityp3=ithetyp(itype(i,1))
5637           do k=1,nsingle
5638             cosph2(k)=0.0d0
5639             sinph2(k)=0.0d0
5640           enddo
5641         endif
5642         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5643         do k=1,ndouble
5644           do l=1,k-1
5645             ccl=cosph1(l)*cosph2(k-l)
5646             ssl=sinph1(l)*sinph2(k-l)
5647             scl=sinph1(l)*cosph2(k-l)
5648             csl=cosph1(l)*sinph2(k-l)
5649             cosph1ph2(l,k)=ccl-ssl
5650             cosph1ph2(k,l)=ccl+ssl
5651             sinph1ph2(l,k)=scl+csl
5652             sinph1ph2(k,l)=scl-csl
5653           enddo
5654         enddo
5655         if (lprn) then
5656         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5657           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5658         write (iout,*) "coskt and sinkt"
5659         do k=1,nntheterm
5660           write (iout,*) k,coskt(k),sinkt(k)
5661         enddo
5662         endif
5663         do k=1,ntheterm
5664           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5665           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5666             *coskt(k)
5667           if (lprn) &
5668           write (iout,*) "k",k,&
5669            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5670            " ethetai",ethetai
5671         enddo
5672         if (lprn) then
5673         write (iout,*) "cosph and sinph"
5674         do k=1,nsingle
5675           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5676         enddo
5677         write (iout,*) "cosph1ph2 and sinph2ph2"
5678         do k=2,ndouble
5679           do l=1,k-1
5680             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5681                sinph1ph2(l,k),sinph1ph2(k,l)
5682           enddo
5683         enddo
5684         write(iout,*) "ethetai",ethetai
5685         endif
5686         do m=1,ntheterm2
5687           do k=1,nsingle
5688             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5689                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5690                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5691                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5692             ethetai=ethetai+sinkt(m)*aux
5693             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5694             dephii=dephii+k*sinkt(m)* &
5695                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5696                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5697             dephii1=dephii1+k*sinkt(m)* &
5698                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5699                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5700             if (lprn) &
5701             write (iout,*) "m",m," k",k," bbthet", &
5702                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5703                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5704                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5705                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5706           enddo
5707         enddo
5708         if (lprn) &
5709         write(iout,*) "ethetai",ethetai
5710         do m=1,ntheterm3
5711           do k=2,ndouble
5712             do l=1,k-1
5713               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5714                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5715                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5716                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5717               ethetai=ethetai+sinkt(m)*aux
5718               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5719               dephii=dephii+l*sinkt(m)* &
5720                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5721                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5722                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5723                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5724               dephii1=dephii1+(k-l)*sinkt(m)* &
5725                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5726                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5727                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5728                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5729               if (lprn) then
5730               write (iout,*) "m",m," k",k," l",l," ffthet",&
5731                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5732                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5733                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5734                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5735                   " ethetai",ethetai
5736               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5737                   cosph1ph2(k,l)*sinkt(m),&
5738                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5739               endif
5740             enddo
5741           enddo
5742         enddo
5743 10      continue
5744 !        lprn1=.true.
5745         if (lprn1) &
5746           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5747          i,theta(i)*rad2deg,phii*rad2deg,&
5748          phii1*rad2deg,ethetai
5749 !        lprn1=.false.
5750         etheta=etheta+ethetai
5751         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5752                                     'ebend',i,ethetai
5753         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5754         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5755         gloc(nphi+i-2,icg)=wang*dethetai
5756       enddo
5757 !-----------thete constrains
5758 !      if (tor_mode.ne.2) then
5759       ethetacnstr=0.0d0
5760 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5761       do i=ithetaconstr_start,ithetaconstr_end
5762         itheta=itheta_constr(i)
5763         thetiii=theta(itheta)
5764         difi=pinorm(thetiii-theta_constr0(i))
5765         if (difi.gt.theta_drange(i)) then
5766           difi=difi-theta_drange(i)
5767           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5768           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5769          +for_thet_constr(i)*difi**3
5770         else if (difi.lt.-drange(i)) then
5771           difi=difi+drange(i)
5772           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5773           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5774          +for_thet_constr(i)*difi**3
5775         else
5776           difi=0.0
5777         endif
5778        if (energy_dec) then
5779         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5780          i,itheta,rad2deg*thetiii, &
5781          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5782          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5783          gloc(itheta+nphi-2,icg)
5784         endif
5785       enddo
5786 !      endif
5787
5788       return
5789       end subroutine ebend
5790 #endif
5791 #ifdef CRYST_SC
5792 !-----------------------------------------------------------------------------
5793       subroutine esc(escloc)
5794 ! Calculate the local energy of a side chain and its derivatives in the
5795 ! corresponding virtual-bond valence angles THETA and the spherical angles
5796 ! ALPHA and OMEGA.
5797 !
5798       use comm_sccalc
5799 !      implicit real*8 (a-h,o-z)
5800 !      include 'DIMENSIONS'
5801 !      include 'COMMON.GEO'
5802 !      include 'COMMON.LOCAL'
5803 !      include 'COMMON.VAR'
5804 !      include 'COMMON.INTERACT'
5805 !      include 'COMMON.DERIV'
5806 !      include 'COMMON.CHAIN'
5807 !      include 'COMMON.IOUNITS'
5808 !      include 'COMMON.NAMES'
5809 !      include 'COMMON.FFIELD'
5810 !      include 'COMMON.CONTROL'
5811       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5812          ddersc0,ddummy,xtemp,temp
5813 !el      real(kind=8) :: time11,time12,time112,theti
5814       real(kind=8) :: escloc,delta
5815 !el      integer :: it,nlobit
5816 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5817 !el local variables
5818       integer :: i,k
5819       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5820        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5821       delta=0.02d0*pi
5822       escloc=0.0D0
5823 !     write (iout,'(a)') 'ESC'
5824       do i=loc_start,loc_end
5825         it=itype(i,1)
5826         if (it.eq.ntyp1) cycle
5827         if (it.eq.10) goto 1
5828         nlobit=nlob(iabs(it))
5829 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5830 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5831         theti=theta(i+1)-pipol
5832         x(1)=dtan(theti)
5833         x(2)=alph(i)
5834         x(3)=omeg(i)
5835
5836         if (x(2).gt.pi-delta) then
5837           xtemp(1)=x(1)
5838           xtemp(2)=pi-delta
5839           xtemp(3)=x(3)
5840           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5841           xtemp(2)=pi
5842           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5843           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5844               escloci,dersc(2))
5845           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5846               ddersc0(1),dersc(1))
5847           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5848               ddersc0(3),dersc(3))
5849           xtemp(2)=pi-delta
5850           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5851           xtemp(2)=pi
5852           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5853           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5854                   dersc0(2),esclocbi,dersc02)
5855           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5856                   dersc12,dersc01)
5857           call splinthet(x(2),0.5d0*delta,ss,ssd)
5858           dersc0(1)=dersc01
5859           dersc0(2)=dersc02
5860           dersc0(3)=0.0d0
5861           do k=1,3
5862             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5863           enddo
5864           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5865 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5866 !    &             esclocbi,ss,ssd
5867           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5868 !         escloci=esclocbi
5869 !         write (iout,*) escloci
5870         else if (x(2).lt.delta) then
5871           xtemp(1)=x(1)
5872           xtemp(2)=delta
5873           xtemp(3)=x(3)
5874           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5875           xtemp(2)=0.0d0
5876           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5877           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
5878               escloci,dersc(2))
5879           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5880               ddersc0(1),dersc(1))
5881           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
5882               ddersc0(3),dersc(3))
5883           xtemp(2)=delta
5884           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5885           xtemp(2)=0.0d0
5886           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5887           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
5888                   dersc0(2),esclocbi,dersc02)
5889           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5890                   dersc12,dersc01)
5891           dersc0(1)=dersc01
5892           dersc0(2)=dersc02
5893           dersc0(3)=0.0d0
5894           call splinthet(x(2),0.5d0*delta,ss,ssd)
5895           do k=1,3
5896             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5897           enddo
5898           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5899 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5900 !    &             esclocbi,ss,ssd
5901           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5902 !         write (iout,*) escloci
5903         else
5904           call enesc(x,escloci,dersc,ddummy,.false.)
5905         endif
5906
5907         escloc=escloc+escloci
5908         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5909            'escloc',i,escloci
5910 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5911
5912         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
5913          wscloc*dersc(1)
5914         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5915         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5916     1   continue
5917       enddo
5918       return
5919       end subroutine esc
5920 !-----------------------------------------------------------------------------
5921       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5922
5923       use comm_sccalc
5924 !      implicit real*8 (a-h,o-z)
5925 !      include 'DIMENSIONS'
5926 !      include 'COMMON.GEO'
5927 !      include 'COMMON.LOCAL'
5928 !      include 'COMMON.IOUNITS'
5929 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5930       real(kind=8),dimension(3) :: x,z,dersc,ddersc
5931       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
5932       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
5933       real(kind=8) :: escloci
5934       logical :: mixed
5935 !el local variables
5936       integer :: j,iii,l,k !el,it,nlobit
5937       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
5938 !el       time11,time12,time112
5939 !       write (iout,*) 'it=',it,' nlobit=',nlobit
5940         escloc_i=0.0D0
5941         do j=1,3
5942           dersc(j)=0.0D0
5943           if (mixed) ddersc(j)=0.0d0
5944         enddo
5945         x3=x(3)
5946
5947 ! Because of periodicity of the dependence of the SC energy in omega we have
5948 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5949 ! To avoid underflows, first compute & store the exponents.
5950
5951         do iii=-1,1
5952
5953           x(3)=x3+iii*dwapi
5954
5955           do j=1,nlobit
5956             do k=1,3
5957               z(k)=x(k)-censc(k,j,it)
5958             enddo
5959             do k=1,3
5960               Axk=0.0D0
5961               do l=1,3
5962                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5963               enddo
5964               Ax(k,j,iii)=Axk
5965             enddo
5966             expfac=0.0D0
5967             do k=1,3
5968               expfac=expfac+Ax(k,j,iii)*z(k)
5969             enddo
5970             contr(j,iii)=expfac
5971           enddo ! j
5972
5973         enddo ! iii
5974
5975         x(3)=x3
5976 ! As in the case of ebend, we want to avoid underflows in exponentiation and
5977 ! subsequent NaNs and INFs in energy calculation.
5978 ! Find the largest exponent
5979         emin=contr(1,-1)
5980         do iii=-1,1
5981           do j=1,nlobit
5982             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5983           enddo
5984         enddo
5985         emin=0.5D0*emin
5986 !d      print *,'it=',it,' emin=',emin
5987
5988 ! Compute the contribution to SC energy and derivatives
5989         do iii=-1,1
5990
5991           do j=1,nlobit
5992 #ifdef OSF
5993             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5994             if(adexp.ne.adexp) adexp=1.0
5995             expfac=dexp(adexp)
5996 #else
5997             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5998 #endif
5999 !d          print *,'j=',j,' expfac=',expfac
6000             escloc_i=escloc_i+expfac
6001             do k=1,3
6002               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6003             enddo
6004             if (mixed) then
6005               do k=1,3,2
6006                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6007                   +gaussc(k,2,j,it))*expfac
6008               enddo
6009             endif
6010           enddo
6011
6012         enddo ! iii
6013
6014         dersc(1)=dersc(1)/cos(theti)**2
6015         ddersc(1)=ddersc(1)/cos(theti)**2
6016         ddersc(3)=ddersc(3)
6017
6018         escloci=-(dlog(escloc_i)-emin)
6019         do j=1,3
6020           dersc(j)=dersc(j)/escloc_i
6021         enddo
6022         if (mixed) then
6023           do j=1,3,2
6024             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6025           enddo
6026         endif
6027       return
6028       end subroutine enesc
6029 !-----------------------------------------------------------------------------
6030       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6031
6032       use comm_sccalc
6033 !      implicit real*8 (a-h,o-z)
6034 !      include 'DIMENSIONS'
6035 !      include 'COMMON.GEO'
6036 !      include 'COMMON.LOCAL'
6037 !      include 'COMMON.IOUNITS'
6038 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6039       real(kind=8),dimension(3) :: x,z,dersc
6040       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6041       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6042       real(kind=8) :: escloci,dersc12,emin
6043       logical :: mixed
6044 !el local varables
6045       integer :: j,k,l !el,it,nlobit
6046       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6047
6048       escloc_i=0.0D0
6049
6050       do j=1,3
6051         dersc(j)=0.0D0
6052       enddo
6053
6054       do j=1,nlobit
6055         do k=1,2
6056           z(k)=x(k)-censc(k,j,it)
6057         enddo
6058         z(3)=dwapi
6059         do k=1,3
6060           Axk=0.0D0
6061           do l=1,3
6062             Axk=Axk+gaussc(l,k,j,it)*z(l)
6063           enddo
6064           Ax(k,j)=Axk
6065         enddo
6066         expfac=0.0D0
6067         do k=1,3
6068           expfac=expfac+Ax(k,j)*z(k)
6069         enddo
6070         contr(j)=expfac
6071       enddo ! j
6072
6073 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6074 ! subsequent NaNs and INFs in energy calculation.
6075 ! Find the largest exponent
6076       emin=contr(1)
6077       do j=1,nlobit
6078         if (emin.gt.contr(j)) emin=contr(j)
6079       enddo
6080       emin=0.5D0*emin
6081
6082 ! Compute the contribution to SC energy and derivatives
6083
6084       dersc12=0.0d0
6085       do j=1,nlobit
6086         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6087         escloc_i=escloc_i+expfac
6088         do k=1,2
6089           dersc(k)=dersc(k)+Ax(k,j)*expfac
6090         enddo
6091         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6092                   +gaussc(1,2,j,it))*expfac
6093         dersc(3)=0.0d0
6094       enddo
6095
6096       dersc(1)=dersc(1)/cos(theti)**2
6097       dersc12=dersc12/cos(theti)**2
6098       escloci=-(dlog(escloc_i)-emin)
6099       do j=1,2
6100         dersc(j)=dersc(j)/escloc_i
6101       enddo
6102       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6103       return
6104       end subroutine enesc_bound
6105 #else
6106 !-----------------------------------------------------------------------------
6107       subroutine esc(escloc)
6108 ! Calculate the local energy of a side chain and its derivatives in the
6109 ! corresponding virtual-bond valence angles THETA and the spherical angles
6110 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6111 ! added by Urszula Kozlowska. 07/11/2007
6112 !
6113       use comm_sccalc
6114 !      implicit real*8 (a-h,o-z)
6115 !      include 'DIMENSIONS'
6116 !      include 'COMMON.GEO'
6117 !      include 'COMMON.LOCAL'
6118 !      include 'COMMON.VAR'
6119 !      include 'COMMON.SCROT'
6120 !      include 'COMMON.INTERACT'
6121 !      include 'COMMON.DERIV'
6122 !      include 'COMMON.CHAIN'
6123 !      include 'COMMON.IOUNITS'
6124 !      include 'COMMON.NAMES'
6125 !      include 'COMMON.FFIELD'
6126 !      include 'COMMON.CONTROL'
6127 !      include 'COMMON.VECTORS'
6128       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6129       real(kind=8),dimension(65) :: x
6130       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6131          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6132       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6133       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6134          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6135 !el local variables
6136       integer :: i,j,k !el,it,nlobit
6137       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6138 !el      real(kind=8) :: time11,time12,time112,theti
6139 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6140       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6141                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6142                    sumene1x,sumene2x,sumene3x,sumene4x,&
6143                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6144                    cosfac2xx,sinfac2yy
6145 #ifdef DEBUG
6146       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6147                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6148                    de_dt_num
6149 #endif
6150 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6151
6152       delta=0.02d0*pi
6153       escloc=0.0D0
6154       do i=loc_start,loc_end
6155         if (itype(i,1).eq.ntyp1) cycle
6156         costtab(i+1) =dcos(theta(i+1))
6157         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6158         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6159         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6160         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6161         cosfac=dsqrt(cosfac2)
6162         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6163         sinfac=dsqrt(sinfac2)
6164         it=iabs(itype(i,1))
6165         if (it.eq.10) goto 1
6166 !
6167 !  Compute the axes of tghe local cartesian coordinates system; store in
6168 !   x_prime, y_prime and z_prime
6169 !
6170         do j=1,3
6171           x_prime(j) = 0.00
6172           y_prime(j) = 0.00
6173           z_prime(j) = 0.00
6174         enddo
6175 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6176 !     &   dc_norm(3,i+nres)
6177         do j = 1,3
6178           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6179           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6180         enddo
6181         do j = 1,3
6182           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6183         enddo
6184 !       write (2,*) "i",i
6185 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6186 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6187 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6188 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6189 !      & " xy",scalar(x_prime(1),y_prime(1)),
6190 !      & " xz",scalar(x_prime(1),z_prime(1)),
6191 !      & " yy",scalar(y_prime(1),y_prime(1)),
6192 !      & " yz",scalar(y_prime(1),z_prime(1)),
6193 !      & " zz",scalar(z_prime(1),z_prime(1))
6194 !
6195 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6196 ! to local coordinate system. Store in xx, yy, zz.
6197 !
6198         xx=0.0d0
6199         yy=0.0d0
6200         zz=0.0d0
6201         do j = 1,3
6202           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6203           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6204           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6205         enddo
6206
6207         xxtab(i)=xx
6208         yytab(i)=yy
6209         zztab(i)=zz
6210 !
6211 ! Compute the energy of the ith side cbain
6212 !
6213 !        write (2,*) "xx",xx," yy",yy," zz",zz
6214         it=iabs(itype(i,1))
6215         do j = 1,65
6216           x(j) = sc_parmin(j,it)
6217         enddo
6218 #ifdef CHECK_COORD
6219 !c diagnostics - remove later
6220         xx1 = dcos(alph(2))
6221         yy1 = dsin(alph(2))*dcos(omeg(2))
6222         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6223         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6224           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6225           xx1,yy1,zz1
6226 !,"  --- ", xx_w,yy_w,zz_w
6227 ! end diagnostics
6228 #endif
6229         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6230          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6231          + x(10)*yy*zz
6232         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6233          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6234          + x(20)*yy*zz
6235         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6236          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6237          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6238          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6239          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6240          +x(40)*xx*yy*zz
6241         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6242          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6243          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6244          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6245          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6246          +x(60)*xx*yy*zz
6247         dsc_i   = 0.743d0+x(61)
6248         dp2_i   = 1.9d0+x(62)
6249         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6250                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6251         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6252                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6253         s1=(1+x(63))/(0.1d0 + dscp1)
6254         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6255         s2=(1+x(65))/(0.1d0 + dscp2)
6256         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6257         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6258       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6259 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6260 !     &   sumene4,
6261 !     &   dscp1,dscp2,sumene
6262 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6263         escloc = escloc + sumene
6264 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6265 !     & ,zz,xx,yy
6266 !#define DEBUG
6267 #ifdef DEBUG
6268 !
6269 ! This section to check the numerical derivatives of the energy of ith side
6270 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6271 ! #define DEBUG in the code to turn it on.
6272 !
6273         write (2,*) "sumene               =",sumene
6274         aincr=1.0d-7
6275         xxsave=xx
6276         xx=xx+aincr
6277         write (2,*) xx,yy,zz
6278         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6279         de_dxx_num=(sumenep-sumene)/aincr
6280         xx=xxsave
6281         write (2,*) "xx+ sumene from enesc=",sumenep
6282         yysave=yy
6283         yy=yy+aincr
6284         write (2,*) xx,yy,zz
6285         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6286         de_dyy_num=(sumenep-sumene)/aincr
6287         yy=yysave
6288         write (2,*) "yy+ sumene from enesc=",sumenep
6289         zzsave=zz
6290         zz=zz+aincr
6291         write (2,*) xx,yy,zz
6292         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6293         de_dzz_num=(sumenep-sumene)/aincr
6294         zz=zzsave
6295         write (2,*) "zz+ sumene from enesc=",sumenep
6296         costsave=cost2tab(i+1)
6297         sintsave=sint2tab(i+1)
6298         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6299         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6300         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6301         de_dt_num=(sumenep-sumene)/aincr
6302         write (2,*) " t+ sumene from enesc=",sumenep
6303         cost2tab(i+1)=costsave
6304         sint2tab(i+1)=sintsave
6305 ! End of diagnostics section.
6306 #endif
6307 !
6308 ! Compute the gradient of esc
6309 !
6310 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6311         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6312         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6313         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6314         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6315         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6316         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6317         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6318         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6319         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6320            *(pom_s1/dscp1+pom_s16*dscp1**4)
6321         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6322            *(pom_s2/dscp2+pom_s26*dscp2**4)
6323         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6324         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6325         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6326         +x(40)*yy*zz
6327         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6328         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6329         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6330         +x(60)*yy*zz
6331         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6332               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6333               +(pom1+pom2)*pom_dx
6334 #ifdef DEBUG
6335         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6336 #endif
6337 !
6338         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6339         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6340         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6341         +x(40)*xx*zz
6342         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6343         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6344         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6345         +x(59)*zz**2 +x(60)*xx*zz
6346         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6347               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6348               +(pom1-pom2)*pom_dy
6349 #ifdef DEBUG
6350         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6351 #endif
6352 !
6353         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6354         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6355         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6356         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6357         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6358         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6359         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6360         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6361 #ifdef DEBUG
6362         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6363 #endif
6364 !
6365         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6366         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6367         +pom1*pom_dt1+pom2*pom_dt2
6368 #ifdef DEBUG
6369         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6370 #endif
6371 !
6372 !
6373        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6374        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6375        cosfac2xx=cosfac2*xx
6376        sinfac2yy=sinfac2*yy
6377        do k = 1,3
6378          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6379             vbld_inv(i+1)
6380          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6381             vbld_inv(i)
6382          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6383          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6384 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6385 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6386 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6387 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6388          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6389          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6390          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6391          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6392          dZZ_Ci1(k)=0.0d0
6393          dZZ_Ci(k)=0.0d0
6394          do j=1,3
6395            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6396            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6397            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6398            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6399          enddo
6400
6401          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6402          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6403          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6404          (z_prime(k)-zz*dC_norm(k,i+nres))
6405 !
6406          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6407          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6408        enddo
6409
6410        do k=1,3
6411          dXX_Ctab(k,i)=dXX_Ci(k)
6412          dXX_C1tab(k,i)=dXX_Ci1(k)
6413          dYY_Ctab(k,i)=dYY_Ci(k)
6414          dYY_C1tab(k,i)=dYY_Ci1(k)
6415          dZZ_Ctab(k,i)=dZZ_Ci(k)
6416          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6417          dXX_XYZtab(k,i)=dXX_XYZ(k)
6418          dYY_XYZtab(k,i)=dYY_XYZ(k)
6419          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6420        enddo
6421
6422        do k = 1,3
6423 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6424 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6425 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6426 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6427 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6428 !     &    dt_dci(k)
6429 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6430 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6431          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6432           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6433          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6434           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6435          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6436           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6437        enddo
6438 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6439 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6440
6441 ! to check gradient call subroutine check_grad
6442
6443     1 continue
6444       enddo
6445       return
6446       end subroutine esc
6447 !-----------------------------------------------------------------------------
6448       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6449 !      implicit none
6450       real(kind=8),dimension(65) :: x
6451       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6452         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6453
6454       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6455         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6456         + x(10)*yy*zz
6457       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6458         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6459         + x(20)*yy*zz
6460       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6461         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6462         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6463         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6464         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6465         +x(40)*xx*yy*zz
6466       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6467         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6468         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6469         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6470         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6471         +x(60)*xx*yy*zz
6472       dsc_i   = 0.743d0+x(61)
6473       dp2_i   = 1.9d0+x(62)
6474       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6475                 *(xx*cost2+yy*sint2))
6476       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6477                 *(xx*cost2-yy*sint2))
6478       s1=(1+x(63))/(0.1d0 + dscp1)
6479       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6480       s2=(1+x(65))/(0.1d0 + dscp2)
6481       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6482       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6483        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6484       enesc=sumene
6485       return
6486       end function enesc
6487 #endif
6488 !-----------------------------------------------------------------------------
6489       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6490 !
6491 ! This procedure calculates two-body contact function g(rij) and its derivative:
6492 !
6493 !           eps0ij                                     !       x < -1
6494 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6495 !            0                                         !       x > 1
6496 !
6497 ! where x=(rij-r0ij)/delta
6498 !
6499 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6500 !
6501 !      implicit none
6502       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6503       real(kind=8) :: x,x2,x4,delta
6504 !     delta=0.02D0*r0ij
6505 !      delta=0.2D0*r0ij
6506       x=(rij-r0ij)/delta
6507       if (x.lt.-1.0D0) then
6508         fcont=eps0ij
6509         fprimcont=0.0D0
6510       else if (x.le.1.0D0) then
6511         x2=x*x
6512         x4=x2*x2
6513         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6514         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6515       else
6516         fcont=0.0D0
6517         fprimcont=0.0D0
6518       endif
6519       return
6520       end subroutine gcont
6521 !-----------------------------------------------------------------------------
6522       subroutine splinthet(theti,delta,ss,ssder)
6523 !      implicit real*8 (a-h,o-z)
6524 !      include 'DIMENSIONS'
6525 !      include 'COMMON.VAR'
6526 !      include 'COMMON.GEO'
6527       real(kind=8) :: theti,delta,ss,ssder
6528       real(kind=8) :: thetup,thetlow
6529       thetup=pi-delta
6530       thetlow=delta
6531       if (theti.gt.pipol) then
6532         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6533       else
6534         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6535         ssder=-ssder
6536       endif
6537       return
6538       end subroutine splinthet
6539 !-----------------------------------------------------------------------------
6540       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6541 !      implicit none
6542       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6543       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6544       a1=fprim0*delta/(f1-f0)
6545       a2=3.0d0-2.0d0*a1
6546       a3=a1-2.0d0
6547       ksi=(x-x0)/delta
6548       ksi2=ksi*ksi
6549       ksi3=ksi2*ksi
6550       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6551       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6552       return
6553       end subroutine spline1
6554 !-----------------------------------------------------------------------------
6555       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6556 !      implicit none
6557       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6558       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6559       ksi=(x-x0)/delta
6560       ksi2=ksi*ksi
6561       ksi3=ksi2*ksi
6562       a1=fprim0x*delta
6563       a2=3*(f1x-f0x)-2*fprim0x*delta
6564       a3=fprim0x*delta-2*(f1x-f0x)
6565       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6566       return
6567       end subroutine spline2
6568 !-----------------------------------------------------------------------------
6569 #ifdef CRYST_TOR
6570 !-----------------------------------------------------------------------------
6571       subroutine etor(etors,edihcnstr)
6572 !      implicit real*8 (a-h,o-z)
6573 !      include 'DIMENSIONS'
6574 !      include 'COMMON.VAR'
6575 !      include 'COMMON.GEO'
6576 !      include 'COMMON.LOCAL'
6577 !      include 'COMMON.TORSION'
6578 !      include 'COMMON.INTERACT'
6579 !      include 'COMMON.DERIV'
6580 !      include 'COMMON.CHAIN'
6581 !      include 'COMMON.NAMES'
6582 !      include 'COMMON.IOUNITS'
6583 !      include 'COMMON.FFIELD'
6584 !      include 'COMMON.TORCNSTR'
6585 !      include 'COMMON.CONTROL'
6586       real(kind=8) :: etors,edihcnstr
6587       logical :: lprn
6588 !el local variables
6589       integer :: i,j,
6590       real(kind=8) :: phii,fac,etors_ii
6591
6592 ! Set lprn=.true. for debugging
6593       lprn=.false.
6594 !      lprn=.true.
6595       etors=0.0D0
6596       do i=iphi_start,iphi_end
6597       etors_ii=0.0D0
6598         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6599             .or. itype(i,1).eq.ntyp1) cycle
6600         itori=itortyp(itype(i-2,1))
6601         itori1=itortyp(itype(i-1,1))
6602         phii=phi(i)
6603         gloci=0.0D0
6604 ! Proline-Proline pair is a special case...
6605         if (itori.eq.3 .and. itori1.eq.3) then
6606           if (phii.gt.-dwapi3) then
6607             cosphi=dcos(3*phii)
6608             fac=1.0D0/(1.0D0-cosphi)
6609             etorsi=v1(1,3,3)*fac
6610             etorsi=etorsi+etorsi
6611             etors=etors+etorsi-v1(1,3,3)
6612             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6613             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6614           endif
6615           do j=1,3
6616             v1ij=v1(j+1,itori,itori1)
6617             v2ij=v2(j+1,itori,itori1)
6618             cosphi=dcos(j*phii)
6619             sinphi=dsin(j*phii)
6620             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6621             if (energy_dec) etors_ii=etors_ii+ &
6622                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6623             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6624           enddo
6625         else
6626           do j=1,nterm_old
6627             v1ij=v1(j,itori,itori1)
6628             v2ij=v2(j,itori,itori1)
6629             cosphi=dcos(j*phii)
6630             sinphi=dsin(j*phii)
6631             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6632             if (energy_dec) etors_ii=etors_ii+ &
6633                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6634             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6635           enddo
6636         endif
6637         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6638              'etor',i,etors_ii
6639         if (lprn) &
6640         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6641         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6642         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6643         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6644 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6645       enddo
6646 ! 6/20/98 - dihedral angle constraints
6647       edihcnstr=0.0d0
6648       do i=1,ndih_constr
6649         itori=idih_constr(i)
6650         phii=phi(itori)
6651         difi=phii-phi0(i)
6652         if (difi.gt.drange(i)) then
6653           difi=difi-drange(i)
6654           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6655           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6656         else if (difi.lt.-drange(i)) then
6657           difi=difi+drange(i)
6658           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6659           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6660         endif
6661 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6662 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6663       enddo
6664 !      write (iout,*) 'edihcnstr',edihcnstr
6665       return
6666       end subroutine etor
6667 !-----------------------------------------------------------------------------
6668       subroutine etor_d(etors_d)
6669       real(kind=8) :: etors_d
6670       etors_d=0.0d0
6671       return
6672       end subroutine etor_d
6673 #else
6674 !-----------------------------------------------------------------------------
6675       subroutine etor(etors,edihcnstr)
6676 !      implicit real*8 (a-h,o-z)
6677 !      include 'DIMENSIONS'
6678 !      include 'COMMON.VAR'
6679 !      include 'COMMON.GEO'
6680 !      include 'COMMON.LOCAL'
6681 !      include 'COMMON.TORSION'
6682 !      include 'COMMON.INTERACT'
6683 !      include 'COMMON.DERIV'
6684 !      include 'COMMON.CHAIN'
6685 !      include 'COMMON.NAMES'
6686 !      include 'COMMON.IOUNITS'
6687 !      include 'COMMON.FFIELD'
6688 !      include 'COMMON.TORCNSTR'
6689 !      include 'COMMON.CONTROL'
6690       real(kind=8) :: etors,edihcnstr
6691       logical :: lprn
6692 !el local variables
6693       integer :: i,j,iblock,itori,itori1
6694       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6695                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6696 ! Set lprn=.true. for debugging
6697       lprn=.false.
6698 !     lprn=.true.
6699       etors=0.0D0
6700       do i=iphi_start,iphi_end
6701         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6702              .or. itype(i-3,1).eq.ntyp1 &
6703              .or. itype(i,1).eq.ntyp1) cycle
6704         etors_ii=0.0D0
6705          if (iabs(itype(i,1)).eq.20) then
6706          iblock=2
6707          else
6708          iblock=1
6709          endif
6710         itori=itortyp(itype(i-2,1))
6711         itori1=itortyp(itype(i-1,1))
6712         phii=phi(i)
6713         gloci=0.0D0
6714 ! Regular cosine and sine terms
6715         do j=1,nterm(itori,itori1,iblock)
6716           v1ij=v1(j,itori,itori1,iblock)
6717           v2ij=v2(j,itori,itori1,iblock)
6718           cosphi=dcos(j*phii)
6719           sinphi=dsin(j*phii)
6720           etors=etors+v1ij*cosphi+v2ij*sinphi
6721           if (energy_dec) etors_ii=etors_ii+ &
6722                      v1ij*cosphi+v2ij*sinphi
6723           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6724         enddo
6725 ! Lorentz terms
6726 !                         v1
6727 !  E = SUM ----------------------------------- - v1
6728 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6729 !
6730         cosphi=dcos(0.5d0*phii)
6731         sinphi=dsin(0.5d0*phii)
6732         do j=1,nlor(itori,itori1,iblock)
6733           vl1ij=vlor1(j,itori,itori1)
6734           vl2ij=vlor2(j,itori,itori1)
6735           vl3ij=vlor3(j,itori,itori1)
6736           pom=vl2ij*cosphi+vl3ij*sinphi
6737           pom1=1.0d0/(pom*pom+1.0d0)
6738           etors=etors+vl1ij*pom1
6739           if (energy_dec) etors_ii=etors_ii+ &
6740                      vl1ij*pom1
6741           pom=-pom*pom1*pom1
6742           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6743         enddo
6744 ! Subtract the constant term
6745         etors=etors-v0(itori,itori1,iblock)
6746           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6747                'etor',i,etors_ii-v0(itori,itori1,iblock)
6748         if (lprn) &
6749         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6750         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6751         (v1(j,itori,itori1,iblock),j=1,6),&
6752         (v2(j,itori,itori1,iblock),j=1,6)
6753         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6754 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6755       enddo
6756 ! 6/20/98 - dihedral angle constraints
6757       edihcnstr=0.0d0
6758 !      do i=1,ndih_constr
6759       do i=idihconstr_start,idihconstr_end
6760         itori=idih_constr(i)
6761         phii=phi(itori)
6762         difi=pinorm(phii-phi0(i))
6763         if (difi.gt.drange(i)) then
6764           difi=difi-drange(i)
6765           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6766           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6767         else if (difi.lt.-drange(i)) then
6768           difi=difi+drange(i)
6769           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6770           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6771         else
6772           difi=0.0
6773         endif
6774 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6775 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6776 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6777       enddo
6778 !d       write (iout,*) 'edihcnstr',edihcnstr
6779       return
6780       end subroutine etor
6781 !-----------------------------------------------------------------------------
6782       subroutine etor_d(etors_d)
6783 ! 6/23/01 Compute double torsional energy
6784 !      implicit real*8 (a-h,o-z)
6785 !      include 'DIMENSIONS'
6786 !      include 'COMMON.VAR'
6787 !      include 'COMMON.GEO'
6788 !      include 'COMMON.LOCAL'
6789 !      include 'COMMON.TORSION'
6790 !      include 'COMMON.INTERACT'
6791 !      include 'COMMON.DERIV'
6792 !      include 'COMMON.CHAIN'
6793 !      include 'COMMON.NAMES'
6794 !      include 'COMMON.IOUNITS'
6795 !      include 'COMMON.FFIELD'
6796 !      include 'COMMON.TORCNSTR'
6797       real(kind=8) :: etors_d,etors_d_ii
6798       logical :: lprn
6799 !el local variables
6800       integer :: i,j,k,l,itori,itori1,itori2,iblock
6801       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6802                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6803                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6804                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6805 ! Set lprn=.true. for debugging
6806       lprn=.false.
6807 !     lprn=.true.
6808       etors_d=0.0D0
6809 !      write(iout,*) "a tu??"
6810       do i=iphid_start,iphid_end
6811         etors_d_ii=0.0D0
6812         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6813             .or. itype(i-3,1).eq.ntyp1 &
6814             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6815         itori=itortyp(itype(i-2,1))
6816         itori1=itortyp(itype(i-1,1))
6817         itori2=itortyp(itype(i,1))
6818         phii=phi(i)
6819         phii1=phi(i+1)
6820         gloci1=0.0D0
6821         gloci2=0.0D0
6822         iblock=1
6823         if (iabs(itype(i+1,1)).eq.20) iblock=2
6824
6825 ! Regular cosine and sine terms
6826         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6827           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6828           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6829           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6830           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6831           cosphi1=dcos(j*phii)
6832           sinphi1=dsin(j*phii)
6833           cosphi2=dcos(j*phii1)
6834           sinphi2=dsin(j*phii1)
6835           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6836            v2cij*cosphi2+v2sij*sinphi2
6837           if (energy_dec) etors_d_ii=etors_d_ii+ &
6838            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6839           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6840           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6841         enddo
6842         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6843           do l=1,k-1
6844             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6845             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6846             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6847             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6848             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6849             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6850             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6851             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6852             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6853               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6854             if (energy_dec) etors_d_ii=etors_d_ii+ &
6855               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6856               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6857             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6858               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6859             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6860               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6861           enddo
6862         enddo
6863         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6864                             'etor_d',i,etors_d_ii
6865         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6866         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6867       enddo
6868       return
6869       end subroutine etor_d
6870 #endif
6871 !-----------------------------------------------------------------------------
6872       subroutine eback_sc_corr(esccor)
6873 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
6874 !        conformational states; temporarily implemented as differences
6875 !        between UNRES torsional potentials (dependent on three types of
6876 !        residues) and the torsional potentials dependent on all 20 types
6877 !        of residues computed from AM1  energy surfaces of terminally-blocked
6878 !        amino-acid residues.
6879 !      implicit real*8 (a-h,o-z)
6880 !      include 'DIMENSIONS'
6881 !      include 'COMMON.VAR'
6882 !      include 'COMMON.GEO'
6883 !      include 'COMMON.LOCAL'
6884 !      include 'COMMON.TORSION'
6885 !      include 'COMMON.SCCOR'
6886 !      include 'COMMON.INTERACT'
6887 !      include 'COMMON.DERIV'
6888 !      include 'COMMON.CHAIN'
6889 !      include 'COMMON.NAMES'
6890 !      include 'COMMON.IOUNITS'
6891 !      include 'COMMON.FFIELD'
6892 !      include 'COMMON.CONTROL'
6893       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
6894                    cosphi,sinphi
6895       logical :: lprn
6896       integer :: i,interty,j,isccori,isccori1,intertyp
6897 ! Set lprn=.true. for debugging
6898       lprn=.false.
6899 !      lprn=.true.
6900 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6901       esccor=0.0D0
6902       do i=itau_start,itau_end
6903         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
6904         esccor_ii=0.0D0
6905         isccori=isccortyp(itype(i-2,1))
6906         isccori1=isccortyp(itype(i-1,1))
6907
6908 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6909         phii=phi(i)
6910         do intertyp=1,3 !intertyp
6911          esccor_ii=0.0D0
6912 !c Added 09 May 2012 (Adasko)
6913 !c  Intertyp means interaction type of backbone mainchain correlation:
6914 !   1 = SC...Ca...Ca...Ca
6915 !   2 = Ca...Ca...Ca...SC
6916 !   3 = SC...Ca...Ca...SCi
6917         gloci=0.0D0
6918         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
6919             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
6920             (itype(i-1,1).eq.ntyp1))) &
6921           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
6922            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
6923            .or.(itype(i,1).eq.ntyp1))) &
6924           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
6925             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
6926             (itype(i-3,1).eq.ntyp1)))) cycle
6927         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
6928         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
6929        cycle
6930        do j=1,nterm_sccor(isccori,isccori1)
6931           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6932           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6933           cosphi=dcos(j*tauangle(intertyp,i))
6934           sinphi=dsin(j*tauangle(intertyp,i))
6935           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6936           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6937           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6938         enddo
6939         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
6940                                 'esccor',i,intertyp,esccor_ii
6941 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6942         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6943         if (lprn) &
6944         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6945         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
6946         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
6947         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6948         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6949        enddo !intertyp
6950       enddo
6951
6952       return
6953       end subroutine eback_sc_corr
6954 !-----------------------------------------------------------------------------
6955       subroutine multibody(ecorr)
6956 ! This subroutine calculates multi-body contributions to energy following
6957 ! the idea of Skolnick et al. If side chains I and J make a contact and
6958 ! at the same time side chains I+1 and J+1 make a contact, an extra
6959 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6960 !      implicit real*8 (a-h,o-z)
6961 !      include 'DIMENSIONS'
6962 !      include 'COMMON.IOUNITS'
6963 !      include 'COMMON.DERIV'
6964 !      include 'COMMON.INTERACT'
6965 !      include 'COMMON.CONTACTS'
6966       real(kind=8),dimension(3) :: gx,gx1
6967       logical :: lprn
6968       real(kind=8) :: ecorr
6969       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
6970 ! Set lprn=.true. for debugging
6971       lprn=.false.
6972
6973       if (lprn) then
6974         write (iout,'(a)') 'Contact function values:'
6975         do i=nnt,nct-2
6976           write (iout,'(i2,20(1x,i2,f10.5))') &
6977               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6978         enddo
6979       endif
6980       ecorr=0.0D0
6981
6982 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
6983 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
6984       do i=nnt,nct
6985         do j=1,3
6986           gradcorr(j,i)=0.0D0
6987           gradxorr(j,i)=0.0D0
6988         enddo
6989       enddo
6990       do i=nnt,nct-2
6991
6992         DO ISHIFT = 3,4
6993
6994         i1=i+ishift
6995         num_conti=num_cont(i)
6996         num_conti1=num_cont(i1)
6997         do jj=1,num_conti
6998           j=jcont(jj,i)
6999           do kk=1,num_conti1
7000             j1=jcont(kk,i1)
7001             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7002 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7003 !d   &                   ' ishift=',ishift
7004 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7005 ! The system gains extra energy.
7006               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7007             endif   ! j1==j+-ishift
7008           enddo     ! kk
7009         enddo       ! jj
7010
7011         ENDDO ! ISHIFT
7012
7013       enddo         ! i
7014       return
7015       end subroutine multibody
7016 !-----------------------------------------------------------------------------
7017       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7018 !      implicit real*8 (a-h,o-z)
7019 !      include 'DIMENSIONS'
7020 !      include 'COMMON.IOUNITS'
7021 !      include 'COMMON.DERIV'
7022 !      include 'COMMON.INTERACT'
7023 !      include 'COMMON.CONTACTS'
7024       real(kind=8),dimension(3) :: gx,gx1
7025       logical :: lprn
7026       integer :: i,j,k,l,jj,kk,m,ll
7027       real(kind=8) :: eij,ekl
7028       lprn=.false.
7029       eij=facont(jj,i)
7030       ekl=facont(kk,k)
7031 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7032 ! Calculate the multi-body contribution to energy.
7033 ! Calculate multi-body contributions to the gradient.
7034 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7035 !d   & k,l,(gacont(m,kk,k),m=1,3)
7036       do m=1,3
7037         gx(m) =ekl*gacont(m,jj,i)
7038         gx1(m)=eij*gacont(m,kk,k)
7039         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7040         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7041         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7042         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7043       enddo
7044       do m=i,j-1
7045         do ll=1,3
7046           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7047         enddo
7048       enddo
7049       do m=k,l-1
7050         do ll=1,3
7051           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7052         enddo
7053       enddo
7054       esccorr=-eij*ekl
7055       return
7056       end function esccorr
7057 !-----------------------------------------------------------------------------
7058       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7059 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7060 !      implicit real*8 (a-h,o-z)
7061 !      include 'DIMENSIONS'
7062 !      include 'COMMON.IOUNITS'
7063 #ifdef MPI
7064       include "mpif.h"
7065 !      integer :: maxconts !max_cont=maxconts  =nres/4
7066       integer,parameter :: max_dim=26
7067       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7068       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7069 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7070 !el      common /przechowalnia/ zapas
7071       integer :: status(MPI_STATUS_SIZE)
7072       integer,dimension((nres/4)*2) :: req !maxconts*2
7073       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7074 #endif
7075 !      include 'COMMON.SETUP'
7076 !      include 'COMMON.FFIELD'
7077 !      include 'COMMON.DERIV'
7078 !      include 'COMMON.INTERACT'
7079 !      include 'COMMON.CONTACTS'
7080 !      include 'COMMON.CONTROL'
7081 !      include 'COMMON.LOCAL'
7082       real(kind=8),dimension(3) :: gx,gx1
7083       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7084       logical :: lprn,ldone
7085 !el local variables
7086       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7087               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7088
7089 ! Set lprn=.true. for debugging
7090       lprn=.false.
7091 #ifdef MPI
7092 !      maxconts=nres/4
7093       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7094       n_corr=0
7095       n_corr1=0
7096       if (nfgtasks.le.1) goto 30
7097       if (lprn) then
7098         write (iout,'(a)') 'Contact function values before RECEIVE:'
7099         do i=nnt,nct-2
7100           write (iout,'(2i3,50(1x,i2,f5.2))') &
7101           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7102           j=1,num_cont_hb(i))
7103         enddo
7104       endif
7105       call flush(iout)
7106       do i=1,ntask_cont_from
7107         ncont_recv(i)=0
7108       enddo
7109       do i=1,ntask_cont_to
7110         ncont_sent(i)=0
7111       enddo
7112 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7113 !     & ntask_cont_to
7114 ! Make the list of contacts to send to send to other procesors
7115 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7116 !      call flush(iout)
7117       do i=iturn3_start,iturn3_end
7118 !        write (iout,*) "make contact list turn3",i," num_cont",
7119 !     &    num_cont_hb(i)
7120         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7121       enddo
7122       do i=iturn4_start,iturn4_end
7123 !        write (iout,*) "make contact list turn4",i," num_cont",
7124 !     &   num_cont_hb(i)
7125         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7126       enddo
7127       do ii=1,nat_sent
7128         i=iat_sent(ii)
7129 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7130 !     &    num_cont_hb(i)
7131         do j=1,num_cont_hb(i)
7132         do k=1,4
7133           jjc=jcont_hb(j,i)
7134           iproc=iint_sent_local(k,jjc,ii)
7135 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7136           if (iproc.gt.0) then
7137             ncont_sent(iproc)=ncont_sent(iproc)+1
7138             nn=ncont_sent(iproc)
7139             zapas(1,nn,iproc)=i
7140             zapas(2,nn,iproc)=jjc
7141             zapas(3,nn,iproc)=facont_hb(j,i)
7142             zapas(4,nn,iproc)=ees0p(j,i)
7143             zapas(5,nn,iproc)=ees0m(j,i)
7144             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7145             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7146             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7147             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7148             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7149             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7150             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7151             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7152             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7153             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7154             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7155             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7156             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7157             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7158             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7159             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7160             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7161             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7162             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7163             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7164             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7165           endif
7166         enddo
7167         enddo
7168       enddo
7169       if (lprn) then
7170       write (iout,*) &
7171         "Numbers of contacts to be sent to other processors",&
7172         (ncont_sent(i),i=1,ntask_cont_to)
7173       write (iout,*) "Contacts sent"
7174       do ii=1,ntask_cont_to
7175         nn=ncont_sent(ii)
7176         iproc=itask_cont_to(ii)
7177         write (iout,*) nn," contacts to processor",iproc,&
7178          " of CONT_TO_COMM group"
7179         do i=1,nn
7180           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7181         enddo
7182       enddo
7183       call flush(iout)
7184       endif
7185       CorrelType=477
7186       CorrelID=fg_rank+1
7187       CorrelType1=478
7188       CorrelID1=nfgtasks+fg_rank+1
7189       ireq=0
7190 ! Receive the numbers of needed contacts from other processors
7191       do ii=1,ntask_cont_from
7192         iproc=itask_cont_from(ii)
7193         ireq=ireq+1
7194         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7195           FG_COMM,req(ireq),IERR)
7196       enddo
7197 !      write (iout,*) "IRECV ended"
7198 !      call flush(iout)
7199 ! Send the number of contacts needed by other processors
7200       do ii=1,ntask_cont_to
7201         iproc=itask_cont_to(ii)
7202         ireq=ireq+1
7203         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7204           FG_COMM,req(ireq),IERR)
7205       enddo
7206 !      write (iout,*) "ISEND ended"
7207 !      write (iout,*) "number of requests (nn)",ireq
7208       call flush(iout)
7209       if (ireq.gt.0) &
7210         call MPI_Waitall(ireq,req,status_array,ierr)
7211 !      write (iout,*)
7212 !     &  "Numbers of contacts to be received from other processors",
7213 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7214 !      call flush(iout)
7215 ! Receive contacts
7216       ireq=0
7217       do ii=1,ntask_cont_from
7218         iproc=itask_cont_from(ii)
7219         nn=ncont_recv(ii)
7220 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7221 !     &   " of CONT_TO_COMM group"
7222         call flush(iout)
7223         if (nn.gt.0) then
7224           ireq=ireq+1
7225           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7226           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7227 !          write (iout,*) "ireq,req",ireq,req(ireq)
7228         endif
7229       enddo
7230 ! Send the contacts to processors that need them
7231       do ii=1,ntask_cont_to
7232         iproc=itask_cont_to(ii)
7233         nn=ncont_sent(ii)
7234 !        write (iout,*) nn," contacts to processor",iproc,
7235 !     &   " of CONT_TO_COMM group"
7236         if (nn.gt.0) then
7237           ireq=ireq+1
7238           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7239             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7240 !          write (iout,*) "ireq,req",ireq,req(ireq)
7241 !          do i=1,nn
7242 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7243 !          enddo
7244         endif
7245       enddo
7246 !      write (iout,*) "number of requests (contacts)",ireq
7247 !      write (iout,*) "req",(req(i),i=1,4)
7248 !      call flush(iout)
7249       if (ireq.gt.0) &
7250        call MPI_Waitall(ireq,req,status_array,ierr)
7251       do iii=1,ntask_cont_from
7252         iproc=itask_cont_from(iii)
7253         nn=ncont_recv(iii)
7254         if (lprn) then
7255         write (iout,*) "Received",nn," contacts from processor",iproc,&
7256          " of CONT_FROM_COMM group"
7257         call flush(iout)
7258         do i=1,nn
7259           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7260         enddo
7261         call flush(iout)
7262         endif
7263         do i=1,nn
7264           ii=zapas_recv(1,i,iii)
7265 ! Flag the received contacts to prevent double-counting
7266           jj=-zapas_recv(2,i,iii)
7267 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7268 !          call flush(iout)
7269           nnn=num_cont_hb(ii)+1
7270           num_cont_hb(ii)=nnn
7271           jcont_hb(nnn,ii)=jj
7272           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7273           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7274           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7275           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7276           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7277           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7278           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7279           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7280           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7281           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7282           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7283           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7284           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7285           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7286           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7287           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7288           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7289           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7290           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7291           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7292           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7293           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7294           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7295           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7296         enddo
7297       enddo
7298       call flush(iout)
7299       if (lprn) then
7300         write (iout,'(a)') 'Contact function values after receive:'
7301         do i=nnt,nct-2
7302           write (iout,'(2i3,50(1x,i3,f5.2))') &
7303           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7304           j=1,num_cont_hb(i))
7305         enddo
7306         call flush(iout)
7307       endif
7308    30 continue
7309 #endif
7310       if (lprn) then
7311         write (iout,'(a)') 'Contact function values:'
7312         do i=nnt,nct-2
7313           write (iout,'(2i3,50(1x,i3,f5.2))') &
7314           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7315           j=1,num_cont_hb(i))
7316         enddo
7317       endif
7318       ecorr=0.0D0
7319
7320 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7321 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7322 ! Remove the loop below after debugging !!!
7323       do i=nnt,nct
7324         do j=1,3
7325           gradcorr(j,i)=0.0D0
7326           gradxorr(j,i)=0.0D0
7327         enddo
7328       enddo
7329 ! Calculate the local-electrostatic correlation terms
7330       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7331         i1=i+1
7332         num_conti=num_cont_hb(i)
7333         num_conti1=num_cont_hb(i+1)
7334         do jj=1,num_conti
7335           j=jcont_hb(jj,i)
7336           jp=iabs(j)
7337           do kk=1,num_conti1
7338             j1=jcont_hb(kk,i1)
7339             jp1=iabs(j1)
7340 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7341 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7342             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7343                 .or. j.lt.0 .and. j1.gt.0) .and. &
7344                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7345 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7346 ! The system gains extra energy.
7347               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7348               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7349                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7350               n_corr=n_corr+1
7351             else if (j1.eq.j) then
7352 ! Contacts I-J and I-(J+1) occur simultaneously.
7353 ! The system loses extra energy.
7354 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7355             endif
7356           enddo ! kk
7357           do kk=1,num_conti
7358             j1=jcont_hb(kk,i)
7359 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7360 !    &         ' jj=',jj,' kk=',kk
7361             if (j1.eq.j+1) then
7362 ! Contacts I-J and (I+1)-J occur simultaneously.
7363 ! The system loses extra energy.
7364 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7365             endif ! j1==j+1
7366           enddo ! kk
7367         enddo ! jj
7368       enddo ! i
7369       return
7370       end subroutine multibody_hb
7371 !-----------------------------------------------------------------------------
7372       subroutine add_hb_contact(ii,jj,itask)
7373 !      implicit real*8 (a-h,o-z)
7374 !      include "DIMENSIONS"
7375 !      include "COMMON.IOUNITS"
7376 !      include "COMMON.CONTACTS"
7377 !      integer,parameter :: maxconts=nres/4
7378       integer,parameter :: max_dim=26
7379       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7380 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7381 !      common /przechowalnia/ zapas
7382       integer :: i,j,ii,jj,iproc,nn,jjc
7383       integer,dimension(4) :: itask
7384 !      write (iout,*) "itask",itask
7385       do i=1,2
7386         iproc=itask(i)
7387         if (iproc.gt.0) then
7388           do j=1,num_cont_hb(ii)
7389             jjc=jcont_hb(j,ii)
7390 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7391             if (jjc.eq.jj) then
7392               ncont_sent(iproc)=ncont_sent(iproc)+1
7393               nn=ncont_sent(iproc)
7394               zapas(1,nn,iproc)=ii
7395               zapas(2,nn,iproc)=jjc
7396               zapas(3,nn,iproc)=facont_hb(j,ii)
7397               zapas(4,nn,iproc)=ees0p(j,ii)
7398               zapas(5,nn,iproc)=ees0m(j,ii)
7399               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7400               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7401               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7402               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7403               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7404               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7405               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7406               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7407               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7408               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7409               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7410               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7411               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7412               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7413               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7414               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7415               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7416               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7417               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7418               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7419               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7420               exit
7421             endif
7422           enddo
7423         endif
7424       enddo
7425       return
7426       end subroutine add_hb_contact
7427 !-----------------------------------------------------------------------------
7428       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7429 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7430 !      implicit real*8 (a-h,o-z)
7431 !      include 'DIMENSIONS'
7432 !      include 'COMMON.IOUNITS'
7433       integer,parameter :: max_dim=70
7434 #ifdef MPI
7435       include "mpif.h"
7436 !      integer :: maxconts !max_cont=maxconts=nres/4
7437       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7438       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7439 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7440 !      common /przechowalnia/ zapas
7441       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7442         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7443         ierr,iii,nnn
7444 #endif
7445 !      include 'COMMON.SETUP'
7446 !      include 'COMMON.FFIELD'
7447 !      include 'COMMON.DERIV'
7448 !      include 'COMMON.LOCAL'
7449 !      include 'COMMON.INTERACT'
7450 !      include 'COMMON.CONTACTS'
7451 !      include 'COMMON.CHAIN'
7452 !      include 'COMMON.CONTROL'
7453       real(kind=8),dimension(3) :: gx,gx1
7454       integer,dimension(nres) :: num_cont_hb_old
7455       logical :: lprn,ldone
7456 !EL      double precision eello4,eello5,eelo6,eello_turn6
7457 !EL      external eello4,eello5,eello6,eello_turn6
7458 !el local variables
7459       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7460               j1,jp1,i1,num_conti1
7461       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7462       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7463
7464 ! Set lprn=.true. for debugging
7465       lprn=.false.
7466       eturn6=0.0d0
7467 #ifdef MPI
7468 !      maxconts=nres/4
7469       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7470       do i=1,nres
7471         num_cont_hb_old(i)=num_cont_hb(i)
7472       enddo
7473       n_corr=0
7474       n_corr1=0
7475       if (nfgtasks.le.1) goto 30
7476       if (lprn) then
7477         write (iout,'(a)') 'Contact function values before RECEIVE:'
7478         do i=nnt,nct-2
7479           write (iout,'(2i3,50(1x,i2,f5.2))') &
7480           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7481           j=1,num_cont_hb(i))
7482         enddo
7483       endif
7484       call flush(iout)
7485       do i=1,ntask_cont_from
7486         ncont_recv(i)=0
7487       enddo
7488       do i=1,ntask_cont_to
7489         ncont_sent(i)=0
7490       enddo
7491 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7492 !     & ntask_cont_to
7493 ! Make the list of contacts to send to send to other procesors
7494       do i=iturn3_start,iturn3_end
7495 !        write (iout,*) "make contact list turn3",i," num_cont",
7496 !     &    num_cont_hb(i)
7497         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7498       enddo
7499       do i=iturn4_start,iturn4_end
7500 !        write (iout,*) "make contact list turn4",i," num_cont",
7501 !     &   num_cont_hb(i)
7502         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7503       enddo
7504       do ii=1,nat_sent
7505         i=iat_sent(ii)
7506 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7507 !     &    num_cont_hb(i)
7508         do j=1,num_cont_hb(i)
7509         do k=1,4
7510           jjc=jcont_hb(j,i)
7511           iproc=iint_sent_local(k,jjc,ii)
7512 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7513           if (iproc.ne.0) then
7514             ncont_sent(iproc)=ncont_sent(iproc)+1
7515             nn=ncont_sent(iproc)
7516             zapas(1,nn,iproc)=i
7517             zapas(2,nn,iproc)=jjc
7518             zapas(3,nn,iproc)=d_cont(j,i)
7519             ind=3
7520             do kk=1,3
7521               ind=ind+1
7522               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7523             enddo
7524             do kk=1,2
7525               do ll=1,2
7526                 ind=ind+1
7527                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7528               enddo
7529             enddo
7530             do jj=1,5
7531               do kk=1,3
7532                 do ll=1,2
7533                   do mm=1,2
7534                     ind=ind+1
7535                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7536                   enddo
7537                 enddo
7538               enddo
7539             enddo
7540           endif
7541         enddo
7542         enddo
7543       enddo
7544       if (lprn) then
7545       write (iout,*) &
7546         "Numbers of contacts to be sent to other processors",&
7547         (ncont_sent(i),i=1,ntask_cont_to)
7548       write (iout,*) "Contacts sent"
7549       do ii=1,ntask_cont_to
7550         nn=ncont_sent(ii)
7551         iproc=itask_cont_to(ii)
7552         write (iout,*) nn," contacts to processor",iproc,&
7553          " of CONT_TO_COMM group"
7554         do i=1,nn
7555           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7556         enddo
7557       enddo
7558       call flush(iout)
7559       endif
7560       CorrelType=477
7561       CorrelID=fg_rank+1
7562       CorrelType1=478
7563       CorrelID1=nfgtasks+fg_rank+1
7564       ireq=0
7565 ! Receive the numbers of needed contacts from other processors
7566       do ii=1,ntask_cont_from
7567         iproc=itask_cont_from(ii)
7568         ireq=ireq+1
7569         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7570           FG_COMM,req(ireq),IERR)
7571       enddo
7572 !      write (iout,*) "IRECV ended"
7573 !      call flush(iout)
7574 ! Send the number of contacts needed by other processors
7575       do ii=1,ntask_cont_to
7576         iproc=itask_cont_to(ii)
7577         ireq=ireq+1
7578         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7579           FG_COMM,req(ireq),IERR)
7580       enddo
7581 !      write (iout,*) "ISEND ended"
7582 !      write (iout,*) "number of requests (nn)",ireq
7583       call flush(iout)
7584       if (ireq.gt.0) &
7585         call MPI_Waitall(ireq,req,status_array,ierr)
7586 !      write (iout,*)
7587 !     &  "Numbers of contacts to be received from other processors",
7588 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7589 !      call flush(iout)
7590 ! Receive contacts
7591       ireq=0
7592       do ii=1,ntask_cont_from
7593         iproc=itask_cont_from(ii)
7594         nn=ncont_recv(ii)
7595 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7596 !     &   " of CONT_TO_COMM group"
7597         call flush(iout)
7598         if (nn.gt.0) then
7599           ireq=ireq+1
7600           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7601           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7602 !          write (iout,*) "ireq,req",ireq,req(ireq)
7603         endif
7604       enddo
7605 ! Send the contacts to processors that need them
7606       do ii=1,ntask_cont_to
7607         iproc=itask_cont_to(ii)
7608         nn=ncont_sent(ii)
7609 !        write (iout,*) nn," contacts to processor",iproc,
7610 !     &   " of CONT_TO_COMM group"
7611         if (nn.gt.0) then
7612           ireq=ireq+1
7613           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7614             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7615 !          write (iout,*) "ireq,req",ireq,req(ireq)
7616 !          do i=1,nn
7617 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7618 !          enddo
7619         endif
7620       enddo
7621 !      write (iout,*) "number of requests (contacts)",ireq
7622 !      write (iout,*) "req",(req(i),i=1,4)
7623 !      call flush(iout)
7624       if (ireq.gt.0) &
7625        call MPI_Waitall(ireq,req,status_array,ierr)
7626       do iii=1,ntask_cont_from
7627         iproc=itask_cont_from(iii)
7628         nn=ncont_recv(iii)
7629         if (lprn) then
7630         write (iout,*) "Received",nn," contacts from processor",iproc,&
7631          " of CONT_FROM_COMM group"
7632         call flush(iout)
7633         do i=1,nn
7634           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7635         enddo
7636         call flush(iout)
7637         endif
7638         do i=1,nn
7639           ii=zapas_recv(1,i,iii)
7640 ! Flag the received contacts to prevent double-counting
7641           jj=-zapas_recv(2,i,iii)
7642 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7643 !          call flush(iout)
7644           nnn=num_cont_hb(ii)+1
7645           num_cont_hb(ii)=nnn
7646           jcont_hb(nnn,ii)=jj
7647           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7648           ind=3
7649           do kk=1,3
7650             ind=ind+1
7651             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7652           enddo
7653           do kk=1,2
7654             do ll=1,2
7655               ind=ind+1
7656               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7657             enddo
7658           enddo
7659           do jj=1,5
7660             do kk=1,3
7661               do ll=1,2
7662                 do mm=1,2
7663                   ind=ind+1
7664                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7665                 enddo
7666               enddo
7667             enddo
7668           enddo
7669         enddo
7670       enddo
7671       call flush(iout)
7672       if (lprn) then
7673         write (iout,'(a)') 'Contact function values after receive:'
7674         do i=nnt,nct-2
7675           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7676           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7677           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7678         enddo
7679         call flush(iout)
7680       endif
7681    30 continue
7682 #endif
7683       if (lprn) then
7684         write (iout,'(a)') 'Contact function values:'
7685         do i=nnt,nct-2
7686           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7687           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7688           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7689         enddo
7690       endif
7691       ecorr=0.0D0
7692       ecorr5=0.0d0
7693       ecorr6=0.0d0
7694
7695 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7696 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7697 ! Remove the loop below after debugging !!!
7698       do i=nnt,nct
7699         do j=1,3
7700           gradcorr(j,i)=0.0D0
7701           gradxorr(j,i)=0.0D0
7702         enddo
7703       enddo
7704 ! Calculate the dipole-dipole interaction energies
7705       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7706       do i=iatel_s,iatel_e+1
7707         num_conti=num_cont_hb(i)
7708         do jj=1,num_conti
7709           j=jcont_hb(jj,i)
7710 #ifdef MOMENT
7711           call dipole(i,j,jj)
7712 #endif
7713         enddo
7714       enddo
7715       endif
7716 ! Calculate the local-electrostatic correlation terms
7717 !                write (iout,*) "gradcorr5 in eello5 before loop"
7718 !                do iii=1,nres
7719 !                  write (iout,'(i5,3f10.5)')
7720 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7721 !                enddo
7722       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7723 !        write (iout,*) "corr loop i",i
7724         i1=i+1
7725         num_conti=num_cont_hb(i)
7726         num_conti1=num_cont_hb(i+1)
7727         do jj=1,num_conti
7728           j=jcont_hb(jj,i)
7729           jp=iabs(j)
7730           do kk=1,num_conti1
7731             j1=jcont_hb(kk,i1)
7732             jp1=iabs(j1)
7733 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7734 !     &         ' jj=',jj,' kk=',kk
7735 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7736             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7737                 .or. j.lt.0 .and. j1.gt.0) .and. &
7738                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7739 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7740 ! The system gains extra energy.
7741               n_corr=n_corr+1
7742               sqd1=dsqrt(d_cont(jj,i))
7743               sqd2=dsqrt(d_cont(kk,i1))
7744               sred_geom = sqd1*sqd2
7745               IF (sred_geom.lt.cutoff_corr) THEN
7746                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7747                   ekont,fprimcont)
7748 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7749 !d     &         ' jj=',jj,' kk=',kk
7750                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7751                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7752                 do l=1,3
7753                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7754                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7755                 enddo
7756                 n_corr1=n_corr1+1
7757 !d               write (iout,*) 'sred_geom=',sred_geom,
7758 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7759 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7760 !d               write (iout,*) "g_contij",g_contij
7761 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7762 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7763                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7764                 if (wcorr4.gt.0.0d0) &
7765                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7766                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7767                        write (iout,'(a6,4i5,0pf7.3)') &
7768                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7769 !                write (iout,*) "gradcorr5 before eello5"
7770 !                do iii=1,nres
7771 !                  write (iout,'(i5,3f10.5)')
7772 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7773 !                enddo
7774                 if (wcorr5.gt.0.0d0) &
7775                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7776 !                write (iout,*) "gradcorr5 after eello5"
7777 !                do iii=1,nres
7778 !                  write (iout,'(i5,3f10.5)')
7779 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7780 !                enddo
7781                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7782                        write (iout,'(a6,4i5,0pf7.3)') &
7783                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7784 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7785 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7786                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7787                      .or. wturn6.eq.0.0d0))then
7788 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7789                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7790                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7791                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7792 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7793 !d     &            'ecorr6=',ecorr6
7794 !d                write (iout,'(4e15.5)') sred_geom,
7795 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7796 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7797 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7798                 else if (wturn6.gt.0.0d0 &
7799                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7800 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7801                   eturn6=eturn6+eello_turn6(i,jj,kk)
7802                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7803                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7804 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7805                 endif
7806               ENDIF
7807 1111          continue
7808             endif
7809           enddo ! kk
7810         enddo ! jj
7811       enddo ! i
7812       do i=1,nres
7813         num_cont_hb(i)=num_cont_hb_old(i)
7814       enddo
7815 !                write (iout,*) "gradcorr5 in eello5"
7816 !                do iii=1,nres
7817 !                  write (iout,'(i5,3f10.5)')
7818 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7819 !                enddo
7820       return
7821       end subroutine multibody_eello
7822 !-----------------------------------------------------------------------------
7823       subroutine add_hb_contact_eello(ii,jj,itask)
7824 !      implicit real*8 (a-h,o-z)
7825 !      include "DIMENSIONS"
7826 !      include "COMMON.IOUNITS"
7827 !      include "COMMON.CONTACTS"
7828 !      integer,parameter :: maxconts=nres/4
7829       integer,parameter :: max_dim=70
7830       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7831 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7832 !      common /przechowalnia/ zapas
7833
7834       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7835       integer,dimension(4) ::itask
7836 !      write (iout,*) "itask",itask
7837       do i=1,2
7838         iproc=itask(i)
7839         if (iproc.gt.0) then
7840           do j=1,num_cont_hb(ii)
7841             jjc=jcont_hb(j,ii)
7842 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7843             if (jjc.eq.jj) then
7844               ncont_sent(iproc)=ncont_sent(iproc)+1
7845               nn=ncont_sent(iproc)
7846               zapas(1,nn,iproc)=ii
7847               zapas(2,nn,iproc)=jjc
7848               zapas(3,nn,iproc)=d_cont(j,ii)
7849               ind=3
7850               do kk=1,3
7851                 ind=ind+1
7852                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7853               enddo
7854               do kk=1,2
7855                 do ll=1,2
7856                   ind=ind+1
7857                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7858                 enddo
7859               enddo
7860               do jj=1,5
7861                 do kk=1,3
7862                   do ll=1,2
7863                     do mm=1,2
7864                       ind=ind+1
7865                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7866                     enddo
7867                   enddo
7868                 enddo
7869               enddo
7870               exit
7871             endif
7872           enddo
7873         endif
7874       enddo
7875       return
7876       end subroutine add_hb_contact_eello
7877 !-----------------------------------------------------------------------------
7878       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7879 !      implicit real*8 (a-h,o-z)
7880 !      include 'DIMENSIONS'
7881 !      include 'COMMON.IOUNITS'
7882 !      include 'COMMON.DERIV'
7883 !      include 'COMMON.INTERACT'
7884 !      include 'COMMON.CONTACTS'
7885       real(kind=8),dimension(3) :: gx,gx1
7886       logical :: lprn
7887 !el local variables
7888       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
7889       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
7890                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
7891                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
7892                    rlocshield
7893
7894       lprn=.false.
7895       eij=facont_hb(jj,i)
7896       ekl=facont_hb(kk,k)
7897       ees0pij=ees0p(jj,i)
7898       ees0pkl=ees0p(kk,k)
7899       ees0mij=ees0m(jj,i)
7900       ees0mkl=ees0m(kk,k)
7901       ekont=eij*ekl
7902       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7903 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7904 ! Following 4 lines for diagnostics.
7905 !d    ees0pkl=0.0D0
7906 !d    ees0pij=1.0D0
7907 !d    ees0mkl=0.0D0
7908 !d    ees0mij=1.0D0
7909 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7910 !     & 'Contacts ',i,j,
7911 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7912 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7913 !     & 'gradcorr_long'
7914 ! Calculate the multi-body contribution to energy.
7915 !      ecorr=ecorr+ekont*ees
7916 ! Calculate multi-body contributions to the gradient.
7917       coeffpees0pij=coeffp*ees0pij
7918       coeffmees0mij=coeffm*ees0mij
7919       coeffpees0pkl=coeffp*ees0pkl
7920       coeffmees0mkl=coeffm*ees0mkl
7921       do ll=1,3
7922 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7923         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
7924         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
7925         coeffmees0mkl*gacontm_hb1(ll,jj,i))
7926         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
7927         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
7928         coeffmees0mkl*gacontm_hb2(ll,jj,i))
7929 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7930         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
7931         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
7932         coeffmees0mij*gacontm_hb1(ll,kk,k))
7933         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
7934         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
7935         coeffmees0mij*gacontm_hb2(ll,kk,k))
7936         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
7937            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
7938            coeffmees0mkl*gacontm_hb3(ll,jj,i))
7939         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7940         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7941         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
7942            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
7943            coeffmees0mij*gacontm_hb3(ll,kk,k))
7944         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7945         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7946 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7947       enddo
7948 !      write (iout,*)
7949 !grad      do m=i+1,j-1
7950 !grad        do ll=1,3
7951 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7952 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7953 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7954 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7955 !grad        enddo
7956 !grad      enddo
7957 !grad      do m=k+1,l-1
7958 !grad        do ll=1,3
7959 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
7960 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
7961 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7962 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7963 !grad        enddo
7964 !grad      enddo
7965 !      write (iout,*) "ehbcorr",ekont*ees
7966       ehbcorr=ekont*ees
7967       if (shield_mode.gt.0) then
7968        j=ees0plist(jj,i)
7969        l=ees0plist(kk,k)
7970 !C        print *,i,j,fac_shield(i),fac_shield(j),
7971 !C     &fac_shield(k),fac_shield(l)
7972         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
7973            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7974           do ilist=1,ishield_list(i)
7975            iresshield=shield_list(ilist,i)
7976            do m=1,3
7977            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7978            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7979                    rlocshield  &
7980             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7981             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7982             +rlocshield
7983            enddo
7984           enddo
7985           do ilist=1,ishield_list(j)
7986            iresshield=shield_list(ilist,j)
7987            do m=1,3
7988            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7989            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
7990                    rlocshield &
7991             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7992            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
7993             +rlocshield
7994            enddo
7995           enddo
7996
7997           do ilist=1,ishield_list(k)
7998            iresshield=shield_list(ilist,k)
7999            do m=1,3
8000            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8001            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8002                    rlocshield &
8003             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8004            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8005             +rlocshield
8006            enddo
8007           enddo
8008           do ilist=1,ishield_list(l)
8009            iresshield=shield_list(ilist,l)
8010            do m=1,3
8011            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8012            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8013                    rlocshield &
8014             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8015            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8016             +rlocshield
8017            enddo
8018           enddo
8019           do m=1,3
8020             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8021                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8022             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8023                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8024             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8025                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8026             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8027                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8028
8029             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8030                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8031             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8032                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8033             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8034                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8035             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8036                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8037
8038            enddo
8039       endif
8040       endif
8041       return
8042       end function ehbcorr
8043 #ifdef MOMENT
8044 !-----------------------------------------------------------------------------
8045       subroutine dipole(i,j,jj)
8046 !      implicit real*8 (a-h,o-z)
8047 !      include 'DIMENSIONS'
8048 !      include 'COMMON.IOUNITS'
8049 !      include 'COMMON.CHAIN'
8050 !      include 'COMMON.FFIELD'
8051 !      include 'COMMON.DERIV'
8052 !      include 'COMMON.INTERACT'
8053 !      include 'COMMON.CONTACTS'
8054 !      include 'COMMON.TORSION'
8055 !      include 'COMMON.VAR'
8056 !      include 'COMMON.GEO'
8057       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8058       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8059       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8060
8061       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8062       allocate(dipderx(3,5,4,maxconts,nres))
8063 !
8064
8065       iti1 = itortyp(itype(i+1,1))
8066       if (j.lt.nres-1) then
8067         itj1 = itortyp(itype(j+1,1))
8068       else
8069         itj1=ntortyp+1
8070       endif
8071       do iii=1,2
8072         dipi(iii,1)=Ub2(iii,i)
8073         dipderi(iii)=Ub2der(iii,i)
8074         dipi(iii,2)=b1(iii,iti1)
8075         dipj(iii,1)=Ub2(iii,j)
8076         dipderj(iii)=Ub2der(iii,j)
8077         dipj(iii,2)=b1(iii,itj1)
8078       enddo
8079       kkk=0
8080       do iii=1,2
8081         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8082         do jjj=1,2
8083           kkk=kkk+1
8084           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8085         enddo
8086       enddo
8087       do kkk=1,5
8088         do lll=1,3
8089           mmm=0
8090           do iii=1,2
8091             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8092               auxvec(1))
8093             do jjj=1,2
8094               mmm=mmm+1
8095               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8096             enddo
8097           enddo
8098         enddo
8099       enddo
8100       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8101       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8102       do iii=1,2
8103         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8104       enddo
8105       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8106       do iii=1,2
8107         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8108       enddo
8109       return
8110       end subroutine dipole
8111 #endif
8112 !-----------------------------------------------------------------------------
8113       subroutine calc_eello(i,j,k,l,jj,kk)
8114 !
8115 ! This subroutine computes matrices and vectors needed to calculate
8116 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8117 !
8118       use comm_kut
8119 !      implicit real*8 (a-h,o-z)
8120 !      include 'DIMENSIONS'
8121 !      include 'COMMON.IOUNITS'
8122 !      include 'COMMON.CHAIN'
8123 !      include 'COMMON.DERIV'
8124 !      include 'COMMON.INTERACT'
8125 !      include 'COMMON.CONTACTS'
8126 !      include 'COMMON.TORSION'
8127 !      include 'COMMON.VAR'
8128 !      include 'COMMON.GEO'
8129 !      include 'COMMON.FFIELD'
8130       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8131       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8132       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8133               itj1
8134 !el      logical :: lprn
8135 !el      common /kutas/ lprn
8136 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8137 !d     & ' jj=',jj,' kk=',kk
8138 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8139 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8140 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8141       do iii=1,2
8142         do jjj=1,2
8143           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8144           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8145         enddo
8146       enddo
8147       call transpose2(aa1(1,1),aa1t(1,1))
8148       call transpose2(aa2(1,1),aa2t(1,1))
8149       do kkk=1,5
8150         do lll=1,3
8151           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8152             aa1tder(1,1,lll,kkk))
8153           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8154             aa2tder(1,1,lll,kkk))
8155         enddo
8156       enddo
8157       if (l.eq.j+1) then
8158 ! parallel orientation of the two CA-CA-CA frames.
8159         if (i.gt.1) then
8160           iti=itortyp(itype(i,1))
8161         else
8162           iti=ntortyp+1
8163         endif
8164         itk1=itortyp(itype(k+1,1))
8165         itj=itortyp(itype(j,1))
8166         if (l.lt.nres-1) then
8167           itl1=itortyp(itype(l+1,1))
8168         else
8169           itl1=ntortyp+1
8170         endif
8171 ! A1 kernel(j+1) A2T
8172 !d        do iii=1,2
8173 !d          write (iout,'(3f10.5,5x,3f10.5)')
8174 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8175 !d        enddo
8176         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8177          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8178          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8179 ! Following matrices are needed only for 6-th order cumulants
8180         IF (wcorr6.gt.0.0d0) THEN
8181         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8182          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8183          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8184         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8185          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8186          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8187          ADtEAderx(1,1,1,1,1,1))
8188         lprn=.false.
8189         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8190          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8191          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8192          ADtEA1derx(1,1,1,1,1,1))
8193         ENDIF
8194 ! End 6-th order cumulants
8195 !d        lprn=.false.
8196 !d        if (lprn) then
8197 !d        write (2,*) 'In calc_eello6'
8198 !d        do iii=1,2
8199 !d          write (2,*) 'iii=',iii
8200 !d          do kkk=1,5
8201 !d            write (2,*) 'kkk=',kkk
8202 !d            do jjj=1,2
8203 !d              write (2,'(3(2f10.5),5x)')
8204 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8205 !d            enddo
8206 !d          enddo
8207 !d        enddo
8208 !d        endif
8209         call transpose2(EUgder(1,1,k),auxmat(1,1))
8210         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8211         call transpose2(EUg(1,1,k),auxmat(1,1))
8212         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8213         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8214         do iii=1,2
8215           do kkk=1,5
8216             do lll=1,3
8217               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8218                 EAEAderx(1,1,lll,kkk,iii,1))
8219             enddo
8220           enddo
8221         enddo
8222 ! A1T kernel(i+1) A2
8223         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8224          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8225          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8226 ! Following matrices are needed only for 6-th order cumulants
8227         IF (wcorr6.gt.0.0d0) THEN
8228         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8229          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8230          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8231         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8232          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8233          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8234          ADtEAderx(1,1,1,1,1,2))
8235         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8236          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8237          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8238          ADtEA1derx(1,1,1,1,1,2))
8239         ENDIF
8240 ! End 6-th order cumulants
8241         call transpose2(EUgder(1,1,l),auxmat(1,1))
8242         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8243         call transpose2(EUg(1,1,l),auxmat(1,1))
8244         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8245         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8246         do iii=1,2
8247           do kkk=1,5
8248             do lll=1,3
8249               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8250                 EAEAderx(1,1,lll,kkk,iii,2))
8251             enddo
8252           enddo
8253         enddo
8254 ! AEAb1 and AEAb2
8255 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8256 ! They are needed only when the fifth- or the sixth-order cumulants are
8257 ! indluded.
8258         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8259         call transpose2(AEA(1,1,1),auxmat(1,1))
8260         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8261         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8262         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8263         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8264         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8265         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8266         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8267         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8268         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8269         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8270         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8271         call transpose2(AEA(1,1,2),auxmat(1,1))
8272         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8273         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8274         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8275         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8276         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8277         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8278         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8279         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8280         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8281         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8282         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8283 ! Calculate the Cartesian derivatives of the vectors.
8284         do iii=1,2
8285           do kkk=1,5
8286             do lll=1,3
8287               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8288               call matvec2(auxmat(1,1),b1(1,iti),&
8289                 AEAb1derx(1,lll,kkk,iii,1,1))
8290               call matvec2(auxmat(1,1),Ub2(1,i),&
8291                 AEAb2derx(1,lll,kkk,iii,1,1))
8292               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8293                 AEAb1derx(1,lll,kkk,iii,2,1))
8294               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8295                 AEAb2derx(1,lll,kkk,iii,2,1))
8296               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8297               call matvec2(auxmat(1,1),b1(1,itj),&
8298                 AEAb1derx(1,lll,kkk,iii,1,2))
8299               call matvec2(auxmat(1,1),Ub2(1,j),&
8300                 AEAb2derx(1,lll,kkk,iii,1,2))
8301               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8302                 AEAb1derx(1,lll,kkk,iii,2,2))
8303               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8304                 AEAb2derx(1,lll,kkk,iii,2,2))
8305             enddo
8306           enddo
8307         enddo
8308         ENDIF
8309 ! End vectors
8310       else
8311 ! Antiparallel orientation of the two CA-CA-CA frames.
8312         if (i.gt.1) then
8313           iti=itortyp(itype(i,1))
8314         else
8315           iti=ntortyp+1
8316         endif
8317         itk1=itortyp(itype(k+1,1))
8318         itl=itortyp(itype(l,1))
8319         itj=itortyp(itype(j,1))
8320         if (j.lt.nres-1) then
8321           itj1=itortyp(itype(j+1,1))
8322         else
8323           itj1=ntortyp+1
8324         endif
8325 ! A2 kernel(j-1)T A1T
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.,EUg(1,1,j),EUgder(1,1,j),&
8328          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8329 ! Following matrices are needed only for 6-th order cumulants
8330         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8331            j.eq.i+4 .and. l.eq.i+3)) THEN
8332         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8333          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8334          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8335         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8336          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8337          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8338          ADtEAderx(1,1,1,1,1,1))
8339         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8340          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8341          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8342          ADtEA1derx(1,1,1,1,1,1))
8343         ENDIF
8344 ! End 6-th order cumulants
8345         call transpose2(EUgder(1,1,k),auxmat(1,1))
8346         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8347         call transpose2(EUg(1,1,k),auxmat(1,1))
8348         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8349         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8350         do iii=1,2
8351           do kkk=1,5
8352             do lll=1,3
8353               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8354                 EAEAderx(1,1,lll,kkk,iii,1))
8355             enddo
8356           enddo
8357         enddo
8358 ! A2T kernel(i+1)T A1
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.,EUg(1,1,k),EUgder(1,1,k),&
8361          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8362 ! Following matrices are needed only for 6-th order cumulants
8363         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8364            j.eq.i+4 .and. l.eq.i+3)) THEN
8365         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8366          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8367          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8368         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8369          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8370          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8371          ADtEAderx(1,1,1,1,1,2))
8372         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8373          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8374          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8375          ADtEA1derx(1,1,1,1,1,2))
8376         ENDIF
8377 ! End 6-th order cumulants
8378         call transpose2(EUgder(1,1,j),auxmat(1,1))
8379         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8380         call transpose2(EUg(1,1,j),auxmat(1,1))
8381         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8382         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8383         do iii=1,2
8384           do kkk=1,5
8385             do lll=1,3
8386               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8387                 EAEAderx(1,1,lll,kkk,iii,2))
8388             enddo
8389           enddo
8390         enddo
8391 ! AEAb1 and AEAb2
8392 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8393 ! They are needed only when the fifth- or the sixth-order cumulants are
8394 ! indluded.
8395         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8396           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8397         call transpose2(AEA(1,1,1),auxmat(1,1))
8398         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8399         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8400         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8401         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8402         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8403         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8404         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8405         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8406         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8407         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8408         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8409         call transpose2(AEA(1,1,2),auxmat(1,1))
8410         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8411         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8412         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8413         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8414         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8415         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8416         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8417         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8418         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8419         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8420         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8421 ! Calculate the Cartesian derivatives of the vectors.
8422         do iii=1,2
8423           do kkk=1,5
8424             do lll=1,3
8425               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8426               call matvec2(auxmat(1,1),b1(1,iti),&
8427                 AEAb1derx(1,lll,kkk,iii,1,1))
8428               call matvec2(auxmat(1,1),Ub2(1,i),&
8429                 AEAb2derx(1,lll,kkk,iii,1,1))
8430               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8431                 AEAb1derx(1,lll,kkk,iii,2,1))
8432               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8433                 AEAb2derx(1,lll,kkk,iii,2,1))
8434               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8435               call matvec2(auxmat(1,1),b1(1,itl),&
8436                 AEAb1derx(1,lll,kkk,iii,1,2))
8437               call matvec2(auxmat(1,1),Ub2(1,l),&
8438                 AEAb2derx(1,lll,kkk,iii,1,2))
8439               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8440                 AEAb1derx(1,lll,kkk,iii,2,2))
8441               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8442                 AEAb2derx(1,lll,kkk,iii,2,2))
8443             enddo
8444           enddo
8445         enddo
8446         ENDIF
8447 ! End vectors
8448       endif
8449       return
8450       end subroutine calc_eello
8451 !-----------------------------------------------------------------------------
8452       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8453       use comm_kut
8454       implicit none
8455       integer :: nderg
8456       logical :: transp
8457       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8458       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8459       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8460       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8461       integer :: iii,kkk,lll
8462       integer :: jjj,mmm
8463 !el      logical :: lprn
8464 !el      common /kutas/ lprn
8465       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8466       do iii=1,nderg
8467         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8468           AKAderg(1,1,iii))
8469       enddo
8470 !d      if (lprn) write (2,*) 'In kernel'
8471       do kkk=1,5
8472 !d        if (lprn) write (2,*) 'kkk=',kkk
8473         do lll=1,3
8474           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8475             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8476 !d          if (lprn) then
8477 !d            write (2,*) 'lll=',lll
8478 !d            write (2,*) 'iii=1'
8479 !d            do jjj=1,2
8480 !d              write (2,'(3(2f10.5),5x)')
8481 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8482 !d            enddo
8483 !d          endif
8484           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8485             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8486 !d          if (lprn) then
8487 !d            write (2,*) 'lll=',lll
8488 !d            write (2,*) 'iii=2'
8489 !d            do jjj=1,2
8490 !d              write (2,'(3(2f10.5),5x)')
8491 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8492 !d            enddo
8493 !d          endif
8494         enddo
8495       enddo
8496       return
8497       end subroutine kernel
8498 !-----------------------------------------------------------------------------
8499       real(kind=8) function eello4(i,j,k,l,jj,kk)
8500 !      implicit real*8 (a-h,o-z)
8501 !      include 'DIMENSIONS'
8502 !      include 'COMMON.IOUNITS'
8503 !      include 'COMMON.CHAIN'
8504 !      include 'COMMON.DERIV'
8505 !      include 'COMMON.INTERACT'
8506 !      include 'COMMON.CONTACTS'
8507 !      include 'COMMON.TORSION'
8508 !      include 'COMMON.VAR'
8509 !      include 'COMMON.GEO'
8510       real(kind=8),dimension(2,2) :: pizda
8511       real(kind=8),dimension(3) :: ggg1,ggg2
8512       real(kind=8) ::  eel4,glongij,glongkl
8513       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8514 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8515 !d        eello4=0.0d0
8516 !d        return
8517 !d      endif
8518 !d      print *,'eello4:',i,j,k,l,jj,kk
8519 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8520 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8521 !old      eij=facont_hb(jj,i)
8522 !old      ekl=facont_hb(kk,k)
8523 !old      ekont=eij*ekl
8524       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8525 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8526       gcorr_loc(k-1)=gcorr_loc(k-1) &
8527          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8528       if (l.eq.j+1) then
8529         gcorr_loc(l-1)=gcorr_loc(l-1) &
8530            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8531       else
8532         gcorr_loc(j-1)=gcorr_loc(j-1) &
8533            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8534       endif
8535       do iii=1,2
8536         do kkk=1,5
8537           do lll=1,3
8538             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8539                               -EAEAderx(2,2,lll,kkk,iii,1)
8540 !d            derx(lll,kkk,iii)=0.0d0
8541           enddo
8542         enddo
8543       enddo
8544 !d      gcorr_loc(l-1)=0.0d0
8545 !d      gcorr_loc(j-1)=0.0d0
8546 !d      gcorr_loc(k-1)=0.0d0
8547 !d      eel4=1.0d0
8548 !d      write (iout,*)'Contacts have occurred for peptide groups',
8549 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8550 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8551       if (j.lt.nres-1) then
8552         j1=j+1
8553         j2=j-1
8554       else
8555         j1=j-1
8556         j2=j-2
8557       endif
8558       if (l.lt.nres-1) then
8559         l1=l+1
8560         l2=l-1
8561       else
8562         l1=l-1
8563         l2=l-2
8564       endif
8565       do ll=1,3
8566 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8567 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8568         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8569         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8570 !grad        ghalf=0.5d0*ggg1(ll)
8571         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8572         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8573         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8574         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8575         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8576         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8577 !grad        ghalf=0.5d0*ggg2(ll)
8578         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8579         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8580         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8581         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8582         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8583         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8584       enddo
8585 !grad      do m=i+1,j-1
8586 !grad        do ll=1,3
8587 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8588 !grad        enddo
8589 !grad      enddo
8590 !grad      do m=k+1,l-1
8591 !grad        do ll=1,3
8592 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8593 !grad        enddo
8594 !grad      enddo
8595 !grad      do m=i+2,j2
8596 !grad        do ll=1,3
8597 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8598 !grad        enddo
8599 !grad      enddo
8600 !grad      do m=k+2,l2
8601 !grad        do ll=1,3
8602 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8603 !grad        enddo
8604 !grad      enddo
8605 !d      do iii=1,nres-3
8606 !d        write (2,*) iii,gcorr_loc(iii)
8607 !d      enddo
8608       eello4=ekont*eel4
8609 !d      write (2,*) 'ekont',ekont
8610 !d      write (iout,*) 'eello4',ekont*eel4
8611       return
8612       end function eello4
8613 !-----------------------------------------------------------------------------
8614       real(kind=8) function eello5(i,j,k,l,jj,kk)
8615 !      implicit real*8 (a-h,o-z)
8616 !      include 'DIMENSIONS'
8617 !      include 'COMMON.IOUNITS'
8618 !      include 'COMMON.CHAIN'
8619 !      include 'COMMON.DERIV'
8620 !      include 'COMMON.INTERACT'
8621 !      include 'COMMON.CONTACTS'
8622 !      include 'COMMON.TORSION'
8623 !      include 'COMMON.VAR'
8624 !      include 'COMMON.GEO'
8625       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8626       real(kind=8),dimension(2) :: vv
8627       real(kind=8),dimension(3) :: ggg1,ggg2
8628       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8629       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8630       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8631 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8632 !                                                                              C
8633 !                            Parallel chains                                   C
8634 !                                                                              C
8635 !          o             o                   o             o                   C
8636 !         /l\           / \             \   / \           / \   /              C
8637 !        /   \         /   \             \ /   \         /   \ /               C
8638 !       j| o |l1       | o |              o| o |         | o |o                C
8639 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8640 !      \i/   \         /   \ /             /   \         /   \                 C
8641 !       o    k1             o                                                  C
8642 !         (I)          (II)                (III)          (IV)                 C
8643 !                                                                              C
8644 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8645 !                                                                              C
8646 !                            Antiparallel chains                               C
8647 !                                                                              C
8648 !          o             o                   o             o                   C
8649 !         /j\           / \             \   / \           / \   /              C
8650 !        /   \         /   \             \ /   \         /   \ /               C
8651 !      j1| o |l        | o |              o| o |         | o |o                C
8652 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8653 !      \i/   \         /   \ /             /   \         /   \                 C
8654 !       o     k1            o                                                  C
8655 !         (I)          (II)                (III)          (IV)                 C
8656 !                                                                              C
8657 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8658 !                                                                              C
8659 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8660 !                                                                              C
8661 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8662 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8663 !d        eello5=0.0d0
8664 !d        return
8665 !d      endif
8666 !d      write (iout,*)
8667 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8668 !d     &   ' and',k,l
8669       itk=itortyp(itype(k,1))
8670       itl=itortyp(itype(l,1))
8671       itj=itortyp(itype(j,1))
8672       eello5_1=0.0d0
8673       eello5_2=0.0d0
8674       eello5_3=0.0d0
8675       eello5_4=0.0d0
8676 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8677 !d     &   eel5_3_num,eel5_4_num)
8678       do iii=1,2
8679         do kkk=1,5
8680           do lll=1,3
8681             derx(lll,kkk,iii)=0.0d0
8682           enddo
8683         enddo
8684       enddo
8685 !d      eij=facont_hb(jj,i)
8686 !d      ekl=facont_hb(kk,k)
8687 !d      ekont=eij*ekl
8688 !d      write (iout,*)'Contacts have occurred for peptide groups',
8689 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8690 !d      goto 1111
8691 ! Contribution from the graph I.
8692 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8693 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8694       call transpose2(EUg(1,1,k),auxmat(1,1))
8695       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8696       vv(1)=pizda(1,1)-pizda(2,2)
8697       vv(2)=pizda(1,2)+pizda(2,1)
8698       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8699        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8700 ! Explicit gradient in virtual-dihedral angles.
8701       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8702        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8703        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8704       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8705       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8706       vv(1)=pizda(1,1)-pizda(2,2)
8707       vv(2)=pizda(1,2)+pizda(2,1)
8708       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8709        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8710        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8711       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8712       vv(1)=pizda(1,1)-pizda(2,2)
8713       vv(2)=pizda(1,2)+pizda(2,1)
8714       if (l.eq.j+1) then
8715         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8716          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8717          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8718       else
8719         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8720          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8721          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8722       endif
8723 ! Cartesian gradient
8724       do iii=1,2
8725         do kkk=1,5
8726           do lll=1,3
8727             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8728               pizda(1,1))
8729             vv(1)=pizda(1,1)-pizda(2,2)
8730             vv(2)=pizda(1,2)+pizda(2,1)
8731             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8732              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8733              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8734           enddo
8735         enddo
8736       enddo
8737 !      goto 1112
8738 !1111  continue
8739 ! Contribution from graph II
8740       call transpose2(EE(1,1,itk),auxmat(1,1))
8741       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8742       vv(1)=pizda(1,1)+pizda(2,2)
8743       vv(2)=pizda(2,1)-pizda(1,2)
8744       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8745        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8746 ! Explicit gradient in virtual-dihedral angles.
8747       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8748        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8749       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8750       vv(1)=pizda(1,1)+pizda(2,2)
8751       vv(2)=pizda(2,1)-pizda(1,2)
8752       if (l.eq.j+1) then
8753         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8754          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8755          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8756       else
8757         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8758          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8759          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8760       endif
8761 ! Cartesian gradient
8762       do iii=1,2
8763         do kkk=1,5
8764           do lll=1,3
8765             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8766               pizda(1,1))
8767             vv(1)=pizda(1,1)+pizda(2,2)
8768             vv(2)=pizda(2,1)-pizda(1,2)
8769             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8770              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8771              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8772           enddo
8773         enddo
8774       enddo
8775 !d      goto 1112
8776 !d1111  continue
8777       if (l.eq.j+1) then
8778 !d        goto 1110
8779 ! Parallel orientation
8780 ! Contribution from graph III
8781         call transpose2(EUg(1,1,l),auxmat(1,1))
8782         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8783         vv(1)=pizda(1,1)-pizda(2,2)
8784         vv(2)=pizda(1,2)+pizda(2,1)
8785         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8786          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8787 ! Explicit gradient in virtual-dihedral angles.
8788         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8789          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8790          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8791         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8792         vv(1)=pizda(1,1)-pizda(2,2)
8793         vv(2)=pizda(1,2)+pizda(2,1)
8794         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8795          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8796          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8797         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8798         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8799         vv(1)=pizda(1,1)-pizda(2,2)
8800         vv(2)=pizda(1,2)+pizda(2,1)
8801         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8802          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8803          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8804 ! Cartesian gradient
8805         do iii=1,2
8806           do kkk=1,5
8807             do lll=1,3
8808               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8809                 pizda(1,1))
8810               vv(1)=pizda(1,1)-pizda(2,2)
8811               vv(2)=pizda(1,2)+pizda(2,1)
8812               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8813                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8814                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8815             enddo
8816           enddo
8817         enddo
8818 !d        goto 1112
8819 ! Contribution from graph IV
8820 !d1110    continue
8821         call transpose2(EE(1,1,itl),auxmat(1,1))
8822         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8823         vv(1)=pizda(1,1)+pizda(2,2)
8824         vv(2)=pizda(2,1)-pizda(1,2)
8825         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8826          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8827 ! Explicit gradient in virtual-dihedral angles.
8828         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8829          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8830         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8831         vv(1)=pizda(1,1)+pizda(2,2)
8832         vv(2)=pizda(2,1)-pizda(1,2)
8833         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8834          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8835          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8836 ! Cartesian gradient
8837         do iii=1,2
8838           do kkk=1,5
8839             do lll=1,3
8840               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8841                 pizda(1,1))
8842               vv(1)=pizda(1,1)+pizda(2,2)
8843               vv(2)=pizda(2,1)-pizda(1,2)
8844               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8845                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8846                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8847             enddo
8848           enddo
8849         enddo
8850       else
8851 ! Antiparallel orientation
8852 ! Contribution from graph III
8853 !        goto 1110
8854         call transpose2(EUg(1,1,j),auxmat(1,1))
8855         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8856         vv(1)=pizda(1,1)-pizda(2,2)
8857         vv(2)=pizda(1,2)+pizda(2,1)
8858         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8859          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8860 ! Explicit gradient in virtual-dihedral angles.
8861         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8862          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8863          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8864         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8865         vv(1)=pizda(1,1)-pizda(2,2)
8866         vv(2)=pizda(1,2)+pizda(2,1)
8867         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8868          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
8869          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8870         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8871         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8872         vv(1)=pizda(1,1)-pizda(2,2)
8873         vv(2)=pizda(1,2)+pizda(2,1)
8874         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8875          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
8876          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8877 ! Cartesian gradient
8878         do iii=1,2
8879           do kkk=1,5
8880             do lll=1,3
8881               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8882                 pizda(1,1))
8883               vv(1)=pizda(1,1)-pizda(2,2)
8884               vv(2)=pizda(1,2)+pizda(2,1)
8885               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8886                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
8887                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8888             enddo
8889           enddo
8890         enddo
8891 !d        goto 1112
8892 ! Contribution from graph IV
8893 1110    continue
8894         call transpose2(EE(1,1,itj),auxmat(1,1))
8895         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8896         vv(1)=pizda(1,1)+pizda(2,2)
8897         vv(2)=pizda(2,1)-pizda(1,2)
8898         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
8899          -0.5d0*scalar2(vv(1),Ctobr(1,j))
8900 ! Explicit gradient in virtual-dihedral angles.
8901         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8902          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8903         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8904         vv(1)=pizda(1,1)+pizda(2,2)
8905         vv(2)=pizda(2,1)-pizda(1,2)
8906         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8907          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
8908          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8909 ! Cartesian gradient
8910         do iii=1,2
8911           do kkk=1,5
8912             do lll=1,3
8913               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8914                 pizda(1,1))
8915               vv(1)=pizda(1,1)+pizda(2,2)
8916               vv(2)=pizda(2,1)-pizda(1,2)
8917               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8918                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
8919                -0.5d0*scalar2(vv(1),Ctobr(1,j))
8920             enddo
8921           enddo
8922         enddo
8923       endif
8924 1112  continue
8925       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8926 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8927 !d        write (2,*) 'ijkl',i,j,k,l
8928 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8929 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8930 !d      endif
8931 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8932 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8933 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8934 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8935       if (j.lt.nres-1) then
8936         j1=j+1
8937         j2=j-1
8938       else
8939         j1=j-1
8940         j2=j-2
8941       endif
8942       if (l.lt.nres-1) then
8943         l1=l+1
8944         l2=l-1
8945       else
8946         l1=l-1
8947         l2=l-2
8948       endif
8949 !d      eij=1.0d0
8950 !d      ekl=1.0d0
8951 !d      ekont=1.0d0
8952 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8953 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
8954 !        summed up outside the subrouine as for the other subroutines
8955 !        handling long-range interactions. The old code is commented out
8956 !        with "cgrad" to keep track of changes.
8957       do ll=1,3
8958 !grad        ggg1(ll)=eel5*g_contij(ll,1)
8959 !grad        ggg2(ll)=eel5*g_contij(ll,2)
8960         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8961         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8962 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8963 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8964 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8965 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8966 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8967 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8968 !     &   gradcorr5ij,
8969 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8970 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8971 !grad        ghalf=0.5d0*ggg1(ll)
8972 !d        ghalf=0.0d0
8973         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8974         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8975         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8976         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8977         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8978         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8979 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8980 !grad        ghalf=0.5d0*ggg2(ll)
8981         ghalf=0.0d0
8982         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8983         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8984         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8985         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8986         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8987         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8988       enddo
8989 !d      goto 1112
8990 !grad      do m=i+1,j-1
8991 !grad        do ll=1,3
8992 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8993 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8994 !grad        enddo
8995 !grad      enddo
8996 !grad      do m=k+1,l-1
8997 !grad        do ll=1,3
8998 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8999 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9000 !grad        enddo
9001 !grad      enddo
9002 !1112  continue
9003 !grad      do m=i+2,j2
9004 !grad        do ll=1,3
9005 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9006 !grad        enddo
9007 !grad      enddo
9008 !grad      do m=k+2,l2
9009 !grad        do ll=1,3
9010 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9011 !grad        enddo
9012 !grad      enddo
9013 !d      do iii=1,nres-3
9014 !d        write (2,*) iii,g_corr5_loc(iii)
9015 !d      enddo
9016       eello5=ekont*eel5
9017 !d      write (2,*) 'ekont',ekont
9018 !d      write (iout,*) 'eello5',ekont*eel5
9019       return
9020       end function eello5
9021 !-----------------------------------------------------------------------------
9022       real(kind=8) function eello6(i,j,k,l,jj,kk)
9023 !      implicit real*8 (a-h,o-z)
9024 !      include 'DIMENSIONS'
9025 !      include 'COMMON.IOUNITS'
9026 !      include 'COMMON.CHAIN'
9027 !      include 'COMMON.DERIV'
9028 !      include 'COMMON.INTERACT'
9029 !      include 'COMMON.CONTACTS'
9030 !      include 'COMMON.TORSION'
9031 !      include 'COMMON.VAR'
9032 !      include 'COMMON.GEO'
9033 !      include 'COMMON.FFIELD'
9034       real(kind=8),dimension(3) :: ggg1,ggg2
9035       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9036                    eello6_6,eel6
9037       real(kind=8) :: gradcorr6ij,gradcorr6kl
9038       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9039 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9040 !d        eello6=0.0d0
9041 !d        return
9042 !d      endif
9043 !d      write (iout,*)
9044 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9045 !d     &   ' and',k,l
9046       eello6_1=0.0d0
9047       eello6_2=0.0d0
9048       eello6_3=0.0d0
9049       eello6_4=0.0d0
9050       eello6_5=0.0d0
9051       eello6_6=0.0d0
9052 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9053 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9054       do iii=1,2
9055         do kkk=1,5
9056           do lll=1,3
9057             derx(lll,kkk,iii)=0.0d0
9058           enddo
9059         enddo
9060       enddo
9061 !d      eij=facont_hb(jj,i)
9062 !d      ekl=facont_hb(kk,k)
9063 !d      ekont=eij*ekl
9064 !d      eij=1.0d0
9065 !d      ekl=1.0d0
9066 !d      ekont=1.0d0
9067       if (l.eq.j+1) then
9068         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9069         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9070         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9071         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9072         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9073         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9074       else
9075         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9076         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9077         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9078         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9079         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9080           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9081         else
9082           eello6_5=0.0d0
9083         endif
9084         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9085       endif
9086 ! If turn contributions are considered, they will be handled separately.
9087       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9088 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9089 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9090 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9091 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9092 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9093 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9094 !d      goto 1112
9095       if (j.lt.nres-1) then
9096         j1=j+1
9097         j2=j-1
9098       else
9099         j1=j-1
9100         j2=j-2
9101       endif
9102       if (l.lt.nres-1) then
9103         l1=l+1
9104         l2=l-1
9105       else
9106         l1=l-1
9107         l2=l-2
9108       endif
9109       do ll=1,3
9110 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9111 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9112 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9113 !grad        ghalf=0.5d0*ggg1(ll)
9114 !d        ghalf=0.0d0
9115         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9116         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9117         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9118         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9119         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9120         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9121         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9122         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9123 !grad        ghalf=0.5d0*ggg2(ll)
9124 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9125 !d        ghalf=0.0d0
9126         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9127         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9128         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9129         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9130         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9131         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9132       enddo
9133 !d      goto 1112
9134 !grad      do m=i+1,j-1
9135 !grad        do ll=1,3
9136 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9137 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9138 !grad        enddo
9139 !grad      enddo
9140 !grad      do m=k+1,l-1
9141 !grad        do ll=1,3
9142 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9143 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9144 !grad        enddo
9145 !grad      enddo
9146 !grad1112  continue
9147 !grad      do m=i+2,j2
9148 !grad        do ll=1,3
9149 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9150 !grad        enddo
9151 !grad      enddo
9152 !grad      do m=k+2,l2
9153 !grad        do ll=1,3
9154 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9155 !grad        enddo
9156 !grad      enddo
9157 !d      do iii=1,nres-3
9158 !d        write (2,*) iii,g_corr6_loc(iii)
9159 !d      enddo
9160       eello6=ekont*eel6
9161 !d      write (2,*) 'ekont',ekont
9162 !d      write (iout,*) 'eello6',ekont*eel6
9163       return
9164       end function eello6
9165 !-----------------------------------------------------------------------------
9166       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9167       use comm_kut
9168 !      implicit real*8 (a-h,o-z)
9169 !      include 'DIMENSIONS'
9170 !      include 'COMMON.IOUNITS'
9171 !      include 'COMMON.CHAIN'
9172 !      include 'COMMON.DERIV'
9173 !      include 'COMMON.INTERACT'
9174 !      include 'COMMON.CONTACTS'
9175 !      include 'COMMON.TORSION'
9176 !      include 'COMMON.VAR'
9177 !      include 'COMMON.GEO'
9178       real(kind=8),dimension(2) :: vv,vv1
9179       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9180       logical :: swap
9181 !el      logical :: lprn
9182 !el      common /kutas/ lprn
9183       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9184       real(kind=8) :: s1,s2,s3,s4,s5
9185 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9186 !                                                                              C
9187 !      Parallel       Antiparallel                                             C
9188 !                                                                              C
9189 !          o             o                                                     C
9190 !         /l\           /j\                                                    C
9191 !        /   \         /   \                                                   C
9192 !       /| o |         | o |\                                                  C
9193 !     \ j|/k\|  /   \  |/k\|l /                                                C
9194 !      \ /   \ /     \ /   \ /                                                 C
9195 !       o     o       o     o                                                  C
9196 !       i             i                                                        C
9197 !                                                                              C
9198 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9199       itk=itortyp(itype(k,1))
9200       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9201       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9202       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9203       call transpose2(EUgC(1,1,k),auxmat(1,1))
9204       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9205       vv1(1)=pizda1(1,1)-pizda1(2,2)
9206       vv1(2)=pizda1(1,2)+pizda1(2,1)
9207       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9208       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9209       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9210       s5=scalar2(vv(1),Dtobr2(1,i))
9211 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9212       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9213       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9214        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9215        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9216        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9217        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9218        +scalar2(vv(1),Dtobr2der(1,i)))
9219       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9220       vv1(1)=pizda1(1,1)-pizda1(2,2)
9221       vv1(2)=pizda1(1,2)+pizda1(2,1)
9222       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9223       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9224       if (l.eq.j+1) then
9225         g_corr6_loc(l-1)=g_corr6_loc(l-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       else
9231         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9232        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9233        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9234        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9235        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9236       endif
9237       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9238       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9239       vv1(1)=pizda1(1,1)-pizda1(2,2)
9240       vv1(2)=pizda1(1,2)+pizda1(2,1)
9241       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9242        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9243        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9244        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9245       do iii=1,2
9246         if (swap) then
9247           ind=3-iii
9248         else
9249           ind=iii
9250         endif
9251         do kkk=1,5
9252           do lll=1,3
9253             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9254             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9255             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9256             call transpose2(EUgC(1,1,k),auxmat(1,1))
9257             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9258               pizda1(1,1))
9259             vv1(1)=pizda1(1,1)-pizda1(2,2)
9260             vv1(2)=pizda1(1,2)+pizda1(2,1)
9261             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9262             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9263              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9264             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9265              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9266             s5=scalar2(vv(1),Dtobr2(1,i))
9267             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9268           enddo
9269         enddo
9270       enddo
9271       return
9272       end function eello6_graph1
9273 !-----------------------------------------------------------------------------
9274       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9275       use comm_kut
9276 !      implicit real*8 (a-h,o-z)
9277 !      include 'DIMENSIONS'
9278 !      include 'COMMON.IOUNITS'
9279 !      include 'COMMON.CHAIN'
9280 !      include 'COMMON.DERIV'
9281 !      include 'COMMON.INTERACT'
9282 !      include 'COMMON.CONTACTS'
9283 !      include 'COMMON.TORSION'
9284 !      include 'COMMON.VAR'
9285 !      include 'COMMON.GEO'
9286       logical :: swap
9287       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9288       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9289 !el      logical :: lprn
9290 !el      common /kutas/ lprn
9291       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9292       real(kind=8) :: s2,s3,s4
9293 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9294 !                                                                              C
9295 !      Parallel       Antiparallel                                             C
9296 !                                                                              C
9297 !          o             o                                                     C
9298 !     \   /l\           /j\   /                                                C
9299 !      \ /   \         /   \ /                                                 C
9300 !       o| o |         | o |o                                                  C
9301 !     \ j|/k\|      \  |/k\|l                                                  C
9302 !      \ /   \       \ /   \                                                   C
9303 !       o             o                                                        C
9304 !       i             i                                                        C
9305 !                                                                              C
9306 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9307 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9308 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9309 !           but not in a cluster cumulant
9310 #ifdef MOMENT
9311       s1=dip(1,jj,i)*dip(1,kk,k)
9312 #endif
9313       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9314       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9315       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9316       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9317       call transpose2(EUg(1,1,k),auxmat(1,1))
9318       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9319       vv(1)=pizda(1,1)-pizda(2,2)
9320       vv(2)=pizda(1,2)+pizda(2,1)
9321       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9322 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9323 #ifdef MOMENT
9324       eello6_graph2=-(s1+s2+s3+s4)
9325 #else
9326       eello6_graph2=-(s2+s3+s4)
9327 #endif
9328 !      eello6_graph2=-s3
9329 ! Derivatives in gamma(i-1)
9330       if (i.gt.1) then
9331 #ifdef MOMENT
9332         s1=dipderg(1,jj,i)*dip(1,kk,k)
9333 #endif
9334         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9335         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9336         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9337         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9338 #ifdef MOMENT
9339         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9340 #else
9341         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9342 #endif
9343 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9344       endif
9345 ! Derivatives in gamma(k-1)
9346 #ifdef MOMENT
9347       s1=dip(1,jj,i)*dipderg(1,kk,k)
9348 #endif
9349       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9350       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9351       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9352       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9353       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9354       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9355       vv(1)=pizda(1,1)-pizda(2,2)
9356       vv(2)=pizda(1,2)+pizda(2,1)
9357       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9358 #ifdef MOMENT
9359       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9360 #else
9361       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9362 #endif
9363 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9364 ! Derivatives in gamma(j-1) or gamma(l-1)
9365       if (j.gt.1) then
9366 #ifdef MOMENT
9367         s1=dipderg(3,jj,i)*dip(1,kk,k)
9368 #endif
9369         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9370         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9371         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9372         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9373         vv(1)=pizda(1,1)-pizda(2,2)
9374         vv(2)=pizda(1,2)+pizda(2,1)
9375         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9376 #ifdef MOMENT
9377         if (swap) then
9378           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9379         else
9380           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9381         endif
9382 #endif
9383         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9384 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9385       endif
9386 ! Derivatives in gamma(l-1) or gamma(j-1)
9387       if (l.gt.1) then
9388 #ifdef MOMENT
9389         s1=dip(1,jj,i)*dipderg(3,kk,k)
9390 #endif
9391         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9392         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9393         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9394         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9395         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9396         vv(1)=pizda(1,1)-pizda(2,2)
9397         vv(2)=pizda(1,2)+pizda(2,1)
9398         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9399 #ifdef MOMENT
9400         if (swap) then
9401           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9402         else
9403           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9404         endif
9405 #endif
9406         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9407 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9408       endif
9409 ! Cartesian derivatives.
9410       if (lprn) then
9411         write (2,*) 'In eello6_graph2'
9412         do iii=1,2
9413           write (2,*) 'iii=',iii
9414           do kkk=1,5
9415             write (2,*) 'kkk=',kkk
9416             do jjj=1,2
9417               write (2,'(3(2f10.5),5x)') &
9418               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9419             enddo
9420           enddo
9421         enddo
9422       endif
9423       do iii=1,2
9424         do kkk=1,5
9425           do lll=1,3
9426 #ifdef MOMENT
9427             if (iii.eq.1) then
9428               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9429             else
9430               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9431             endif
9432 #endif
9433             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9434               auxvec(1))
9435             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9436             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9437               auxvec(1))
9438             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9439             call transpose2(EUg(1,1,k),auxmat(1,1))
9440             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9441               pizda(1,1))
9442             vv(1)=pizda(1,1)-pizda(2,2)
9443             vv(2)=pizda(1,2)+pizda(2,1)
9444             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9445 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9446 #ifdef MOMENT
9447             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9448 #else
9449             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9450 #endif
9451             if (swap) then
9452               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9453             else
9454               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9455             endif
9456           enddo
9457         enddo
9458       enddo
9459       return
9460       end function eello6_graph2
9461 !-----------------------------------------------------------------------------
9462       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9463 !      implicit real*8 (a-h,o-z)
9464 !      include 'DIMENSIONS'
9465 !      include 'COMMON.IOUNITS'
9466 !      include 'COMMON.CHAIN'
9467 !      include 'COMMON.DERIV'
9468 !      include 'COMMON.INTERACT'
9469 !      include 'COMMON.CONTACTS'
9470 !      include 'COMMON.TORSION'
9471 !      include 'COMMON.VAR'
9472 !      include 'COMMON.GEO'
9473       real(kind=8),dimension(2) :: vv,auxvec
9474       real(kind=8),dimension(2,2) :: pizda,auxmat
9475       logical :: swap
9476       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9477       real(kind=8) :: s1,s2,s3,s4
9478 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9479 !                                                                              C
9480 !      Parallel       Antiparallel                                             C
9481 !                                                                              C
9482 !          o             o                                                     C
9483 !         /l\   /   \   /j\                                                    C
9484 !        /   \ /     \ /   \                                                   C
9485 !       /| o |o       o| o |\                                                  C
9486 !       j|/k\|  /      |/k\|l /                                                C
9487 !        /   \ /       /   \ /                                                 C
9488 !       /     o       /     o                                                  C
9489 !       i             i                                                        C
9490 !                                                                              C
9491 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9492 !
9493 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9494 !           energy moment and not to the cluster cumulant.
9495       iti=itortyp(itype(i,1))
9496       if (j.lt.nres-1) then
9497         itj1=itortyp(itype(j+1,1))
9498       else
9499         itj1=ntortyp+1
9500       endif
9501       itk=itortyp(itype(k,1))
9502       itk1=itortyp(itype(k+1,1))
9503       if (l.lt.nres-1) then
9504         itl1=itortyp(itype(l+1,1))
9505       else
9506         itl1=ntortyp+1
9507       endif
9508 #ifdef MOMENT
9509       s1=dip(4,jj,i)*dip(4,kk,k)
9510 #endif
9511       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9512       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9513       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9514       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9515       call transpose2(EE(1,1,itk),auxmat(1,1))
9516       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9517       vv(1)=pizda(1,1)+pizda(2,2)
9518       vv(2)=pizda(2,1)-pizda(1,2)
9519       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9520 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9521 !d     & "sum",-(s2+s3+s4)
9522 #ifdef MOMENT
9523       eello6_graph3=-(s1+s2+s3+s4)
9524 #else
9525       eello6_graph3=-(s2+s3+s4)
9526 #endif
9527 !      eello6_graph3=-s4
9528 ! Derivatives in gamma(k-1)
9529       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9530       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9531       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9532       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9533 ! Derivatives in gamma(l-1)
9534       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9535       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9536       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9537       vv(1)=pizda(1,1)+pizda(2,2)
9538       vv(2)=pizda(2,1)-pizda(1,2)
9539       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9540       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9541 ! Cartesian derivatives.
9542       do iii=1,2
9543         do kkk=1,5
9544           do lll=1,3
9545 #ifdef MOMENT
9546             if (iii.eq.1) then
9547               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9548             else
9549               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9550             endif
9551 #endif
9552             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9553               auxvec(1))
9554             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9555             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9556               auxvec(1))
9557             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9558             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9559               pizda(1,1))
9560             vv(1)=pizda(1,1)+pizda(2,2)
9561             vv(2)=pizda(2,1)-pizda(1,2)
9562             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9563 #ifdef MOMENT
9564             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9565 #else
9566             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9567 #endif
9568             if (swap) then
9569               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9570             else
9571               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9572             endif
9573 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9574           enddo
9575         enddo
9576       enddo
9577       return
9578       end function eello6_graph3
9579 !-----------------------------------------------------------------------------
9580       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9581 !      implicit real*8 (a-h,o-z)
9582 !      include 'DIMENSIONS'
9583 !      include 'COMMON.IOUNITS'
9584 !      include 'COMMON.CHAIN'
9585 !      include 'COMMON.DERIV'
9586 !      include 'COMMON.INTERACT'
9587 !      include 'COMMON.CONTACTS'
9588 !      include 'COMMON.TORSION'
9589 !      include 'COMMON.VAR'
9590 !      include 'COMMON.GEO'
9591 !      include 'COMMON.FFIELD'
9592       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9593       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9594       logical :: swap
9595       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9596               iii,kkk,lll
9597       real(kind=8) :: s1,s2,s3,s4
9598 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9599 !                                                                              C
9600 !      Parallel       Antiparallel                                             C
9601 !                                                                              C
9602 !          o             o                                                     C
9603 !         /l\   /   \   /j\                                                    C
9604 !        /   \ /     \ /   \                                                   C
9605 !       /| o |o       o| o |\                                                  C
9606 !     \ j|/k\|      \  |/k\|l                                                  C
9607 !      \ /   \       \ /   \                                                   C
9608 !       o     \       o     \                                                  C
9609 !       i             i                                                        C
9610 !                                                                              C
9611 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9612 !
9613 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9614 !           energy moment and not to the cluster cumulant.
9615 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9616       iti=itortyp(itype(i,1))
9617       itj=itortyp(itype(j,1))
9618       if (j.lt.nres-1) then
9619         itj1=itortyp(itype(j+1,1))
9620       else
9621         itj1=ntortyp+1
9622       endif
9623       itk=itortyp(itype(k,1))
9624       if (k.lt.nres-1) then
9625         itk1=itortyp(itype(k+1,1))
9626       else
9627         itk1=ntortyp+1
9628       endif
9629       itl=itortyp(itype(l,1))
9630       if (l.lt.nres-1) then
9631         itl1=itortyp(itype(l+1,1))
9632       else
9633         itl1=ntortyp+1
9634       endif
9635 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9636 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9637 !d     & ' itl',itl,' itl1',itl1
9638 #ifdef MOMENT
9639       if (imat.eq.1) then
9640         s1=dip(3,jj,i)*dip(3,kk,k)
9641       else
9642         s1=dip(2,jj,j)*dip(2,kk,l)
9643       endif
9644 #endif
9645       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9646       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9647       if (j.eq.l+1) then
9648         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9649         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9650       else
9651         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9652         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9653       endif
9654       call transpose2(EUg(1,1,k),auxmat(1,1))
9655       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9656       vv(1)=pizda(1,1)-pizda(2,2)
9657       vv(2)=pizda(2,1)+pizda(1,2)
9658       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9659 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9660 #ifdef MOMENT
9661       eello6_graph4=-(s1+s2+s3+s4)
9662 #else
9663       eello6_graph4=-(s2+s3+s4)
9664 #endif
9665 ! Derivatives in gamma(i-1)
9666       if (i.gt.1) then
9667 #ifdef MOMENT
9668         if (imat.eq.1) then
9669           s1=dipderg(2,jj,i)*dip(3,kk,k)
9670         else
9671           s1=dipderg(4,jj,j)*dip(2,kk,l)
9672         endif
9673 #endif
9674         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9675         if (j.eq.l+1) then
9676           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9677           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9678         else
9679           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9680           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9681         endif
9682         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9683         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9684 !d          write (2,*) 'turn6 derivatives'
9685 #ifdef MOMENT
9686           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9687 #else
9688           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9689 #endif
9690         else
9691 #ifdef MOMENT
9692           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9693 #else
9694           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9695 #endif
9696         endif
9697       endif
9698 ! Derivatives in gamma(k-1)
9699 #ifdef MOMENT
9700       if (imat.eq.1) then
9701         s1=dip(3,jj,i)*dipderg(2,kk,k)
9702       else
9703         s1=dip(2,jj,j)*dipderg(4,kk,l)
9704       endif
9705 #endif
9706       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9707       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9708       if (j.eq.l+1) then
9709         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9710         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9711       else
9712         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9713         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9714       endif
9715       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9716       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9717       vv(1)=pizda(1,1)-pizda(2,2)
9718       vv(2)=pizda(2,1)+pizda(1,2)
9719       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9720       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9721 #ifdef MOMENT
9722         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9723 #else
9724         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9725 #endif
9726       else
9727 #ifdef MOMENT
9728         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9729 #else
9730         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9731 #endif
9732       endif
9733 ! Derivatives in gamma(j-1) or gamma(l-1)
9734       if (l.eq.j+1 .and. l.gt.1) then
9735         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9736         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9737         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9738         vv(1)=pizda(1,1)-pizda(2,2)
9739         vv(2)=pizda(2,1)+pizda(1,2)
9740         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9741         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9742       else if (j.gt.1) then
9743         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9744         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9745         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9746         vv(1)=pizda(1,1)-pizda(2,2)
9747         vv(2)=pizda(2,1)+pizda(1,2)
9748         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9749         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9750           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9751         else
9752           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9753         endif
9754       endif
9755 ! Cartesian derivatives.
9756       do iii=1,2
9757         do kkk=1,5
9758           do lll=1,3
9759 #ifdef MOMENT
9760             if (iii.eq.1) then
9761               if (imat.eq.1) then
9762                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9763               else
9764                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9765               endif
9766             else
9767               if (imat.eq.1) then
9768                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9769               else
9770                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9771               endif
9772             endif
9773 #endif
9774             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9775               auxvec(1))
9776             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9777             if (j.eq.l+1) then
9778               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9779                 b1(1,itj1),auxvec(1))
9780               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9781             else
9782               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9783                 b1(1,itl1),auxvec(1))
9784               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9785             endif
9786             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9787               pizda(1,1))
9788             vv(1)=pizda(1,1)-pizda(2,2)
9789             vv(2)=pizda(2,1)+pizda(1,2)
9790             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9791             if (swap) then
9792               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9793 #ifdef MOMENT
9794                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9795                    -(s1+s2+s4)
9796 #else
9797                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9798                    -(s2+s4)
9799 #endif
9800                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9801               else
9802 #ifdef MOMENT
9803                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9804 #else
9805                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9806 #endif
9807                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9808               endif
9809             else
9810 #ifdef MOMENT
9811               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9812 #else
9813               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9814 #endif
9815               if (l.eq.j+1) then
9816                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9817               else
9818                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9819               endif
9820             endif
9821           enddo
9822         enddo
9823       enddo
9824       return
9825       end function eello6_graph4
9826 !-----------------------------------------------------------------------------
9827       real(kind=8) function eello_turn6(i,jj,kk)
9828 !      implicit real*8 (a-h,o-z)
9829 !      include 'DIMENSIONS'
9830 !      include 'COMMON.IOUNITS'
9831 !      include 'COMMON.CHAIN'
9832 !      include 'COMMON.DERIV'
9833 !      include 'COMMON.INTERACT'
9834 !      include 'COMMON.CONTACTS'
9835 !      include 'COMMON.TORSION'
9836 !      include 'COMMON.VAR'
9837 !      include 'COMMON.GEO'
9838       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9839       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9840       real(kind=8),dimension(3) :: ggg1,ggg2
9841       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9842       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9843 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9844 !           the respective energy moment and not to the cluster cumulant.
9845 !el local variables
9846       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9847       integer :: j1,j2,l1,l2,ll
9848       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9849       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9850       s1=0.0d0
9851       s8=0.0d0
9852       s13=0.0d0
9853 !
9854       eello_turn6=0.0d0
9855       j=i+4
9856       k=i+1
9857       l=i+3
9858       iti=itortyp(itype(i,1))
9859       itk=itortyp(itype(k,1))
9860       itk1=itortyp(itype(k+1,1))
9861       itl=itortyp(itype(l,1))
9862       itj=itortyp(itype(j,1))
9863 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9864 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
9865 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9866 !d        eello6=0.0d0
9867 !d        return
9868 !d      endif
9869 !d      write (iout,*)
9870 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9871 !d     &   ' and',k,l
9872 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
9873       do iii=1,2
9874         do kkk=1,5
9875           do lll=1,3
9876             derx_turn(lll,kkk,iii)=0.0d0
9877           enddo
9878         enddo
9879       enddo
9880 !d      eij=1.0d0
9881 !d      ekl=1.0d0
9882 !d      ekont=1.0d0
9883       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9884 !d      eello6_5=0.0d0
9885 !d      write (2,*) 'eello6_5',eello6_5
9886 #ifdef MOMENT
9887       call transpose2(AEA(1,1,1),auxmat(1,1))
9888       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9889       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9890       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9891 #endif
9892       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9893       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9894       s2 = scalar2(b1(1,itk),vtemp1(1))
9895 #ifdef MOMENT
9896       call transpose2(AEA(1,1,2),atemp(1,1))
9897       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9898       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9899       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9900 #endif
9901       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9902       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9903       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9904 #ifdef MOMENT
9905       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9906       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9907       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9908       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9909       ss13 = scalar2(b1(1,itk),vtemp4(1))
9910       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9911 #endif
9912 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9913 !      s1=0.0d0
9914 !      s2=0.0d0
9915 !      s8=0.0d0
9916 !      s12=0.0d0
9917 !      s13=0.0d0
9918       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9919 ! Derivatives in gamma(i+2)
9920       s1d =0.0d0
9921       s8d =0.0d0
9922 #ifdef MOMENT
9923       call transpose2(AEA(1,1,1),auxmatd(1,1))
9924       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9925       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9926       call transpose2(AEAderg(1,1,2),atempd(1,1))
9927       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9928       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9929 #endif
9930       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9931       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9932       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9933 !      s1d=0.0d0
9934 !      s2d=0.0d0
9935 !      s8d=0.0d0
9936 !      s12d=0.0d0
9937 !      s13d=0.0d0
9938       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9939 ! Derivatives in gamma(i+3)
9940 #ifdef MOMENT
9941       call transpose2(AEA(1,1,1),auxmatd(1,1))
9942       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9943       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9944       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9945 #endif
9946       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9947       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9948       s2d = scalar2(b1(1,itk),vtemp1d(1))
9949 #ifdef MOMENT
9950       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9951       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9952 #endif
9953       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9954 #ifdef MOMENT
9955       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9956       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9957       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9958 #endif
9959 !      s1d=0.0d0
9960 !      s2d=0.0d0
9961 !      s8d=0.0d0
9962 !      s12d=0.0d0
9963 !      s13d=0.0d0
9964 #ifdef MOMENT
9965       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9966                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9967 #else
9968       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
9969                     -0.5d0*ekont*(s2d+s12d)
9970 #endif
9971 ! Derivatives in gamma(i+4)
9972       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9973       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9974       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9975 #ifdef MOMENT
9976       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9977       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9978       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9979 #endif
9980 !      s1d=0.0d0
9981 !      s2d=0.0d0
9982 !      s8d=0.0d0
9983 !      s12d=0.0d0
9984 !      s13d=0.0d0
9985 #ifdef MOMENT
9986       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9987 #else
9988       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9989 #endif
9990 ! Derivatives in gamma(i+5)
9991 #ifdef MOMENT
9992       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9993       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9994       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9995 #endif
9996       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9997       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9998       s2d = scalar2(b1(1,itk),vtemp1d(1))
9999 #ifdef MOMENT
10000       call transpose2(AEA(1,1,2),atempd(1,1))
10001       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10002       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10003 #endif
10004       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10005       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10006 #ifdef MOMENT
10007       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10008       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10009       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10010 #endif
10011 !      s1d=0.0d0
10012 !      s2d=0.0d0
10013 !      s8d=0.0d0
10014 !      s12d=0.0d0
10015 !      s13d=0.0d0
10016 #ifdef MOMENT
10017       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10018                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10019 #else
10020       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10021                     -0.5d0*ekont*(s2d+s12d)
10022 #endif
10023 ! Cartesian derivatives
10024       do iii=1,2
10025         do kkk=1,5
10026           do lll=1,3
10027 #ifdef MOMENT
10028             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10029             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10030             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10031 #endif
10032             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10033             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10034                 vtemp1d(1))
10035             s2d = scalar2(b1(1,itk),vtemp1d(1))
10036 #ifdef MOMENT
10037             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10038             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10039             s8d = -(atempd(1,1)+atempd(2,2))* &
10040                  scalar2(cc(1,1,itl),vtemp2(1))
10041 #endif
10042             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10043                  auxmatd(1,1))
10044             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10045             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10046 !      s1d=0.0d0
10047 !      s2d=0.0d0
10048 !      s8d=0.0d0
10049 !      s12d=0.0d0
10050 !      s13d=0.0d0
10051 #ifdef MOMENT
10052             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10053               - 0.5d0*(s1d+s2d)
10054 #else
10055             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10056               - 0.5d0*s2d
10057 #endif
10058 #ifdef MOMENT
10059             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10060               - 0.5d0*(s8d+s12d)
10061 #else
10062             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10063               - 0.5d0*s12d
10064 #endif
10065           enddo
10066         enddo
10067       enddo
10068 #ifdef MOMENT
10069       do kkk=1,5
10070         do lll=1,3
10071           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10072             achuj_tempd(1,1))
10073           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10074           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10075           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10076           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10077           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10078             vtemp4d(1))
10079           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10080           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10081           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10082         enddo
10083       enddo
10084 #endif
10085 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10086 !d     &  16*eel_turn6_num
10087 !d      goto 1112
10088       if (j.lt.nres-1) then
10089         j1=j+1
10090         j2=j-1
10091       else
10092         j1=j-1
10093         j2=j-2
10094       endif
10095       if (l.lt.nres-1) then
10096         l1=l+1
10097         l2=l-1
10098       else
10099         l1=l-1
10100         l2=l-2
10101       endif
10102       do ll=1,3
10103 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10104 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10105 !grad        ghalf=0.5d0*ggg1(ll)
10106 !d        ghalf=0.0d0
10107         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10108         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10109         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10110           +ekont*derx_turn(ll,2,1)
10111         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10112         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10113           +ekont*derx_turn(ll,4,1)
10114         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10115         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10116         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10117 !grad        ghalf=0.5d0*ggg2(ll)
10118 !d        ghalf=0.0d0
10119         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10120           +ekont*derx_turn(ll,2,2)
10121         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10122         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10123           +ekont*derx_turn(ll,4,2)
10124         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10125         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10126         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10127       enddo
10128 !d      goto 1112
10129 !grad      do m=i+1,j-1
10130 !grad        do ll=1,3
10131 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10132 !grad        enddo
10133 !grad      enddo
10134 !grad      do m=k+1,l-1
10135 !grad        do ll=1,3
10136 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10137 !grad        enddo
10138 !grad      enddo
10139 !grad1112  continue
10140 !grad      do m=i+2,j2
10141 !grad        do ll=1,3
10142 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10143 !grad        enddo
10144 !grad      enddo
10145 !grad      do m=k+2,l2
10146 !grad        do ll=1,3
10147 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10148 !grad        enddo
10149 !grad      enddo
10150 !d      do iii=1,nres-3
10151 !d        write (2,*) iii,g_corr6_loc(iii)
10152 !d      enddo
10153       eello_turn6=ekont*eel_turn6
10154 !d      write (2,*) 'ekont',ekont
10155 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10156       return
10157       end function eello_turn6
10158 !-----------------------------------------------------------------------------
10159       subroutine MATVEC2(A1,V1,V2)
10160 !DIR$ INLINEALWAYS MATVEC2
10161 #ifndef OSF
10162 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10163 #endif
10164 !      implicit real*8 (a-h,o-z)
10165 !      include 'DIMENSIONS'
10166       real(kind=8),dimension(2) :: V1,V2
10167       real(kind=8),dimension(2,2) :: A1
10168       real(kind=8) :: vaux1,vaux2
10169 !      DO 1 I=1,2
10170 !        VI=0.0
10171 !        DO 3 K=1,2
10172 !    3     VI=VI+A1(I,K)*V1(K)
10173 !        Vaux(I)=VI
10174 !    1 CONTINUE
10175
10176       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10177       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10178
10179       v2(1)=vaux1
10180       v2(2)=vaux2
10181       end subroutine MATVEC2
10182 !-----------------------------------------------------------------------------
10183       subroutine MATMAT2(A1,A2,A3)
10184 #ifndef OSF
10185 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10186 #endif
10187 !      implicit real*8 (a-h,o-z)
10188 !      include 'DIMENSIONS'
10189       real(kind=8),dimension(2,2) :: A1,A2,A3
10190       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10191 !      DIMENSION AI3(2,2)
10192 !        DO  J=1,2
10193 !          A3IJ=0.0
10194 !          DO K=1,2
10195 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10196 !          enddo
10197 !          A3(I,J)=A3IJ
10198 !       enddo
10199 !      enddo
10200
10201       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10202       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10203       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10204       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10205
10206       A3(1,1)=AI3_11
10207       A3(2,1)=AI3_21
10208       A3(1,2)=AI3_12
10209       A3(2,2)=AI3_22
10210       end subroutine MATMAT2
10211 !-----------------------------------------------------------------------------
10212       real(kind=8) function scalar2(u,v)
10213 !DIR$ INLINEALWAYS scalar2
10214       implicit none
10215       real(kind=8),dimension(2) :: u,v
10216       real(kind=8) :: sc
10217       integer :: i
10218       scalar2=u(1)*v(1)+u(2)*v(2)
10219       return
10220       end function scalar2
10221 !-----------------------------------------------------------------------------
10222       subroutine transpose2(a,at)
10223 !DIR$ INLINEALWAYS transpose2
10224 #ifndef OSF
10225 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10226 #endif
10227       implicit none
10228       real(kind=8),dimension(2,2) :: a,at
10229       at(1,1)=a(1,1)
10230       at(1,2)=a(2,1)
10231       at(2,1)=a(1,2)
10232       at(2,2)=a(2,2)
10233       return
10234       end subroutine transpose2
10235 !-----------------------------------------------------------------------------
10236       subroutine transpose(n,a,at)
10237       implicit none
10238       integer :: n,i,j
10239       real(kind=8),dimension(n,n) :: a,at
10240       do i=1,n
10241         do j=1,n
10242           at(j,i)=a(i,j)
10243         enddo
10244       enddo
10245       return
10246       end subroutine transpose
10247 !-----------------------------------------------------------------------------
10248       subroutine prodmat3(a1,a2,kk,transp,prod)
10249 !DIR$ INLINEALWAYS prodmat3
10250 #ifndef OSF
10251 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10252 #endif
10253       implicit none
10254       integer :: i,j
10255       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10256       logical :: transp
10257 !rc      double precision auxmat(2,2),prod_(2,2)
10258
10259       if (transp) then
10260 !rc        call transpose2(kk(1,1),auxmat(1,1))
10261 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10262 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10263
10264            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10265        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10266            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10267        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10268            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10269        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10270            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10271        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10272
10273       else
10274 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10275 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10276
10277            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10278         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10279            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10280         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10281            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10282         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10283            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10284         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10285
10286       endif
10287 !      call transpose2(a2(1,1),a2t(1,1))
10288
10289 !rc      print *,transp
10290 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10291 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10292
10293       return
10294       end subroutine prodmat3
10295 !-----------------------------------------------------------------------------
10296 ! energy_p_new_barrier.F
10297 !-----------------------------------------------------------------------------
10298       subroutine sum_gradient
10299 !      implicit real*8 (a-h,o-z)
10300       use io_base, only: pdbout
10301 !      include 'DIMENSIONS'
10302 #ifndef ISNAN
10303       external proc_proc
10304 #ifdef WINPGI
10305 !MS$ATTRIBUTES C ::  proc_proc
10306 #endif
10307 #endif
10308 #ifdef MPI
10309       include 'mpif.h'
10310 #endif
10311       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10312                    gloc_scbuf !(3,maxres)
10313
10314       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10315 !#endif
10316 !el local variables
10317       integer :: i,j,k,ierror,ierr
10318       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10319                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10320                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10321                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10322                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10323                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10324                    gsccorr_max,gsccorrx_max,time00
10325
10326 !      include 'COMMON.SETUP'
10327 !      include 'COMMON.IOUNITS'
10328 !      include 'COMMON.FFIELD'
10329 !      include 'COMMON.DERIV'
10330 !      include 'COMMON.INTERACT'
10331 !      include 'COMMON.SBRIDGE'
10332 !      include 'COMMON.CHAIN'
10333 !      include 'COMMON.VAR'
10334 !      include 'COMMON.CONTROL'
10335 !      include 'COMMON.TIME1'
10336 !      include 'COMMON.MAXGRAD'
10337 !      include 'COMMON.SCCOR'
10338 #ifdef TIMING
10339       time01=MPI_Wtime()
10340 #endif
10341 #ifdef DEBUG
10342       write (iout,*) "sum_gradient gvdwc, gvdwx"
10343       do i=1,nres
10344         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10345          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10346       enddo
10347       call flush(iout)
10348 #endif
10349 #ifdef MPI
10350         gradbufc=0.0d0
10351         gradbufx=0.0d0
10352         gradbufc_sum=0.0d0
10353         gloc_scbuf=0.0d0
10354         glocbuf=0.0d0
10355 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10356         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10357           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10358 #endif
10359 !
10360 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10361 !            in virtual-bond-vector coordinates
10362 !
10363 #ifdef DEBUG
10364 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10365 !      do i=1,nres-1
10366 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10367 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10368 !      enddo
10369 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10370 !      do i=1,nres-1
10371 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10372 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10373 !      enddo
10374       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10375       do i=1,nres
10376         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10377          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10378          (gvdwc_scpp(j,i),j=1,3)
10379       enddo
10380       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10381       do i=1,nres
10382         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10383          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10384          (gelc_loc_long(j,i),j=1,3)
10385       enddo
10386       call flush(iout)
10387 #endif
10388 #ifdef SPLITELE
10389       do i=0,nct
10390         do j=1,3
10391           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10392                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10393                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10394                       wel_loc*gel_loc_long(j,i)+ &
10395                       wcorr*gradcorr_long(j,i)+ &
10396                       wcorr5*gradcorr5_long(j,i)+ &
10397                       wcorr6*gradcorr6_long(j,i)+ &
10398                       wturn6*gcorr6_turn_long(j,i)+ &
10399                       wstrain*ghpbc(j,i) &
10400                      +wliptran*gliptranc(j,i) &
10401                      +gradafm(j,i) &
10402                      +welec*gshieldc(j,i) &
10403                      +wcorr*gshieldc_ec(j,i) &
10404                      +wturn3*gshieldc_t3(j,i)&
10405                      +wturn4*gshieldc_t4(j,i)&
10406                      +wel_loc*gshieldc_ll(j,i)&
10407                      +wtube*gg_tube(j,i) &
10408                      +wbond_nucl*gradb_nucl(j,i)
10409         enddo
10410       enddo
10411 #else
10412       do i=0,nct
10413         do j=1,3
10414           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10415                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10416                       welec*gelc_long(j,i)+ &
10417                       wbond*gradb(j,i)+ &
10418                       wel_loc*gel_loc_long(j,i)+ &
10419                       wcorr*gradcorr_long(j,i)+ &
10420                       wcorr5*gradcorr5_long(j,i)+ &
10421                       wcorr6*gradcorr6_long(j,i)+ &
10422                       wturn6*gcorr6_turn_long(j,i)+ &
10423                       wstrain*ghpbc(j,i) &
10424                      +wliptran*gliptranc(j,i) &
10425                      +gradafm(j,i) &
10426                      +welec*gshieldc(j,i)&
10427                      +wcorr*gshieldc_ec(j,i) &
10428                      +wturn4*gshieldc_t4(j,i) &
10429                      +wel_loc*gshieldc_ll(j,i)&
10430                      +wtube*gg_tube(j,i) &
10431                      +wbond_nucl*gradb_nucl(j,i)
10432
10433         enddo
10434       enddo
10435 #endif
10436 #ifdef MPI
10437       if (nfgtasks.gt.1) then
10438       time00=MPI_Wtime()
10439 #ifdef DEBUG
10440       write (iout,*) "gradbufc before allreduce"
10441       do i=1,nres
10442         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10443       enddo
10444       call flush(iout)
10445 #endif
10446       do i=0,nres
10447         do j=1,3
10448           gradbufc_sum(j,i)=gradbufc(j,i)
10449         enddo
10450       enddo
10451 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10452 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10453 !      time_reduce=time_reduce+MPI_Wtime()-time00
10454 #ifdef DEBUG
10455 !      write (iout,*) "gradbufc_sum after allreduce"
10456 !      do i=1,nres
10457 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10458 !      enddo
10459 !      call flush(iout)
10460 #endif
10461 #ifdef TIMING
10462 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10463 #endif
10464       do i=0,nres
10465         do k=1,3
10466           gradbufc(k,i)=0.0d0
10467         enddo
10468       enddo
10469 #ifdef DEBUG
10470       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10471       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10472                         " jgrad_end  ",jgrad_end(i),&
10473                         i=igrad_start,igrad_end)
10474 #endif
10475 !
10476 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10477 ! do not parallelize this part.
10478 !
10479 !      do i=igrad_start,igrad_end
10480 !        do j=jgrad_start(i),jgrad_end(i)
10481 !          do k=1,3
10482 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10483 !          enddo
10484 !        enddo
10485 !      enddo
10486       do j=1,3
10487         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10488       enddo
10489       do i=nres-2,-1,-1
10490         do j=1,3
10491           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10492         enddo
10493       enddo
10494 #ifdef DEBUG
10495       write (iout,*) "gradbufc after summing"
10496       do i=1,nres
10497         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10498       enddo
10499       call flush(iout)
10500 #endif
10501       else
10502 #endif
10503 !el#define DEBUG
10504 #ifdef DEBUG
10505       write (iout,*) "gradbufc"
10506       do i=1,nres
10507         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10508       enddo
10509       call flush(iout)
10510 #endif
10511 !el#undef DEBUG
10512       do i=-1,nres
10513         do j=1,3
10514           gradbufc_sum(j,i)=gradbufc(j,i)
10515           gradbufc(j,i)=0.0d0
10516         enddo
10517       enddo
10518       do j=1,3
10519         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10520       enddo
10521       do i=nres-2,-1,-1
10522         do j=1,3
10523           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10524         enddo
10525       enddo
10526 !      do i=nnt,nres-1
10527 !        do k=1,3
10528 !          gradbufc(k,i)=0.0d0
10529 !        enddo
10530 !        do j=i+1,nres
10531 !          do k=1,3
10532 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10533 !          enddo
10534 !        enddo
10535 !      enddo
10536 !el#define DEBUG
10537 #ifdef DEBUG
10538       write (iout,*) "gradbufc after summing"
10539       do i=1,nres
10540         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10541       enddo
10542       call flush(iout)
10543 #endif
10544 !el#undef DEBUG
10545 #ifdef MPI
10546       endif
10547 #endif
10548       do k=1,3
10549         gradbufc(k,nres)=0.0d0
10550       enddo
10551 !el----------------
10552 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10553 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10554 !el-----------------
10555       do i=-1,nct
10556         do j=1,3
10557 #ifdef SPLITELE
10558           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10559                       wel_loc*gel_loc(j,i)+ &
10560                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10561                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10562                       wel_loc*gel_loc_long(j,i)+ &
10563                       wcorr*gradcorr_long(j,i)+ &
10564                       wcorr5*gradcorr5_long(j,i)+ &
10565                       wcorr6*gradcorr6_long(j,i)+ &
10566                       wturn6*gcorr6_turn_long(j,i))+ &
10567                       wbond*gradb(j,i)+ &
10568                       wcorr*gradcorr(j,i)+ &
10569                       wturn3*gcorr3_turn(j,i)+ &
10570                       wturn4*gcorr4_turn(j,i)+ &
10571                       wcorr5*gradcorr5(j,i)+ &
10572                       wcorr6*gradcorr6(j,i)+ &
10573                       wturn6*gcorr6_turn(j,i)+ &
10574                       wsccor*gsccorc(j,i) &
10575                      +wscloc*gscloc(j,i)  &
10576                      +wliptran*gliptranc(j,i) &
10577                      +gradafm(j,i) &
10578                      +welec*gshieldc(j,i) &
10579                      +welec*gshieldc_loc(j,i) &
10580                      +wcorr*gshieldc_ec(j,i) &
10581                      +wcorr*gshieldc_loc_ec(j,i) &
10582                      +wturn3*gshieldc_t3(j,i) &
10583                      +wturn3*gshieldc_loc_t3(j,i) &
10584                      +wturn4*gshieldc_t4(j,i) &
10585                      +wturn4*gshieldc_loc_t4(j,i) &
10586                      +wel_loc*gshieldc_ll(j,i) &
10587                      +wel_loc*gshieldc_loc_ll(j,i) &
10588                      +wtube*gg_tube(j,i) &
10589                      +wbond_nucl*gradb_nucl(j,i)
10590
10591
10592
10593 #else
10594           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10595                       wel_loc*gel_loc(j,i)+ &
10596                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10597                       welec*gelc_long(j,i)+ &
10598                       wel_loc*gel_loc_long(j,i)+ &
10599 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10600                       wcorr5*gradcorr5_long(j,i)+ &
10601                       wcorr6*gradcorr6_long(j,i)+ &
10602                       wturn6*gcorr6_turn_long(j,i))+ &
10603                       wbond*gradb(j,i)+ &
10604                       wcorr*gradcorr(j,i)+ &
10605                       wturn3*gcorr3_turn(j,i)+ &
10606                       wturn4*gcorr4_turn(j,i)+ &
10607                       wcorr5*gradcorr5(j,i)+ &
10608                       wcorr6*gradcorr6(j,i)+ &
10609                       wturn6*gcorr6_turn(j,i)+ &
10610                       wsccor*gsccorc(j,i) &
10611                      +wscloc*gscloc(j,i) &
10612                      +gradafm(j,i) &
10613                      +wliptran*gliptranc(j,i) &
10614                      +welec*gshieldc(j,i) &
10615                      +welec*gshieldc_loc(j,) &
10616                      +wcorr*gshieldc_ec(j,i) &
10617                      +wcorr*gshieldc_loc_ec(j,i) &
10618                      +wturn3*gshieldc_t3(j,i) &
10619                      +wturn3*gshieldc_loc_t3(j,i) &
10620                      +wturn4*gshieldc_t4(j,i) &
10621                      +wturn4*gshieldc_loc_t4(j,i) &
10622                      +wel_loc*gshieldc_ll(j,i) &
10623                      +wel_loc*gshieldc_loc_ll(j,i) &
10624                      +wtube*gg_tube(j,i) &
10625                      +wbond_nucl*gradb_nucl(j,i)
10626
10627
10628
10629
10630 #endif
10631           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10632                         wbond*gradbx(j,i)+ &
10633                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10634                         wsccor*gsccorx(j,i) &
10635                        +wscloc*gsclocx(j,i) &
10636                        +wliptran*gliptranx(j,i) &
10637                        +welec*gshieldx(j,i)     &
10638                        +wcorr*gshieldx_ec(j,i)  &
10639                        +wturn3*gshieldx_t3(j,i) &
10640                        +wturn4*gshieldx_t4(j,i) &
10641                        +wel_loc*gshieldx_ll(j,i)&
10642                        +wtube*gg_tube_sc(j,i)   &
10643                        +wbond_nucl*gradbx_nucl(j,i)
10644
10645
10646
10647         enddo
10648       enddo
10649 #ifdef DEBUG
10650       write (iout,*) "gloc before adding corr"
10651       do i=1,4*nres
10652         write (iout,*) i,gloc(i,icg)
10653       enddo
10654 #endif
10655       do i=1,nres-3
10656         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10657          +wcorr5*g_corr5_loc(i) &
10658          +wcorr6*g_corr6_loc(i) &
10659          +wturn4*gel_loc_turn4(i) &
10660          +wturn3*gel_loc_turn3(i) &
10661          +wturn6*gel_loc_turn6(i) &
10662          +wel_loc*gel_loc_loc(i)
10663       enddo
10664 #ifdef DEBUG
10665       write (iout,*) "gloc after adding corr"
10666       do i=1,4*nres
10667         write (iout,*) i,gloc(i,icg)
10668       enddo
10669 #endif
10670 #ifdef MPI
10671       if (nfgtasks.gt.1) then
10672         do j=1,3
10673           do i=1,nres
10674             gradbufc(j,i)=gradc(j,i,icg)
10675             gradbufx(j,i)=gradx(j,i,icg)
10676           enddo
10677         enddo
10678         do i=1,4*nres
10679           glocbuf(i)=gloc(i,icg)
10680         enddo
10681 !#define DEBUG
10682 #ifdef DEBUG
10683       write (iout,*) "gloc_sc before reduce"
10684       do i=1,nres
10685        do j=1,1
10686         write (iout,*) i,j,gloc_sc(j,i,icg)
10687        enddo
10688       enddo
10689 #endif
10690 !#undef DEBUG
10691         do i=1,nres
10692          do j=1,3
10693           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10694          enddo
10695         enddo
10696         time00=MPI_Wtime()
10697         call MPI_Barrier(FG_COMM,IERR)
10698         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10699         time00=MPI_Wtime()
10700         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10701           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10702         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,&
10703           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10704         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10705           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10706         time_reduce=time_reduce+MPI_Wtime()-time00
10707         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10708           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10709         time_reduce=time_reduce+MPI_Wtime()-time00
10710 !#define DEBUG
10711 #ifdef DEBUG
10712       write (iout,*) "gloc_sc after reduce"
10713       do i=1,nres
10714        do j=1,1
10715         write (iout,*) i,j,gloc_sc(j,i,icg)
10716        enddo
10717       enddo
10718 #endif
10719 !#undef DEBUG
10720 #ifdef DEBUG
10721       write (iout,*) "gloc after reduce"
10722       do i=1,4*nres
10723         write (iout,*) i,gloc(i,icg)
10724       enddo
10725 #endif
10726       endif
10727 #endif
10728       if (gnorm_check) then
10729 !
10730 ! Compute the maximum elements of the gradient
10731 !
10732       gvdwc_max=0.0d0
10733       gvdwc_scp_max=0.0d0
10734       gelc_max=0.0d0
10735       gvdwpp_max=0.0d0
10736       gradb_max=0.0d0
10737       ghpbc_max=0.0d0
10738       gradcorr_max=0.0d0
10739       gel_loc_max=0.0d0
10740       gcorr3_turn_max=0.0d0
10741       gcorr4_turn_max=0.0d0
10742       gradcorr5_max=0.0d0
10743       gradcorr6_max=0.0d0
10744       gcorr6_turn_max=0.0d0
10745       gsccorc_max=0.0d0
10746       gscloc_max=0.0d0
10747       gvdwx_max=0.0d0
10748       gradx_scp_max=0.0d0
10749       ghpbx_max=0.0d0
10750       gradxorr_max=0.0d0
10751       gsccorx_max=0.0d0
10752       gsclocx_max=0.0d0
10753       do i=1,nct
10754         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10755         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10756         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10757         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10758          gvdwc_scp_max=gvdwc_scp_norm
10759         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10760         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10761         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10762         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10763         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10764         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10765         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10766         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10767         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10768         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10769         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10770         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10771         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10772           gcorr3_turn(1,i)))
10773         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10774           gcorr3_turn_max=gcorr3_turn_norm
10775         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10776           gcorr4_turn(1,i)))
10777         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10778           gcorr4_turn_max=gcorr4_turn_norm
10779         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10780         if (gradcorr5_norm.gt.gradcorr5_max) &
10781           gradcorr5_max=gradcorr5_norm
10782         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10783         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10784         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10785           gcorr6_turn(1,i)))
10786         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10787           gcorr6_turn_max=gcorr6_turn_norm
10788         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
10789         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
10790         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
10791         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
10792         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
10793         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
10794         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
10795         if (gradx_scp_norm.gt.gradx_scp_max) &
10796           gradx_scp_max=gradx_scp_norm
10797         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
10798         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
10799         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
10800         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
10801         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
10802         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
10803         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
10804         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
10805       enddo
10806       if (gradout) then
10807 #ifdef AIX
10808         open(istat,file=statname,position="append")
10809 #else
10810         open(istat,file=statname,access="append")
10811 #endif
10812         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
10813            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
10814            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
10815            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
10816            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
10817            gsccorx_max,gsclocx_max
10818         close(istat)
10819         if (gvdwc_max.gt.1.0d4) then
10820           write (iout,*) "gvdwc gvdwx gradb gradbx"
10821           do i=nnt,nct
10822             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
10823               gradb(j,i),gradbx(j,i),j=1,3)
10824           enddo
10825           call pdbout(0.0d0,'cipiszcze',iout)
10826           call flush(iout)
10827         endif
10828       endif
10829       endif
10830 !el#define DEBUG
10831 #ifdef DEBUG
10832       write (iout,*) "gradc gradx gloc"
10833       do i=1,nres
10834         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
10835          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
10836       enddo
10837 #endif
10838 !el#undef DEBUG
10839 #ifdef TIMING
10840       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
10841 #endif
10842       return
10843       end subroutine sum_gradient
10844 !-----------------------------------------------------------------------------
10845       subroutine sc_grad
10846 !      implicit real*8 (a-h,o-z)
10847       use calc_data
10848 !      include 'DIMENSIONS'
10849 !      include 'COMMON.CHAIN'
10850 !      include 'COMMON.DERIV'
10851 !      include 'COMMON.CALC'
10852 !      include 'COMMON.IOUNITS'
10853       real(kind=8), dimension(3) :: dcosom1,dcosom2
10854 !      print *,"wchodze"
10855       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
10856       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
10857       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
10858            -2.0D0*alf12*eps3der+sigder*sigsq_om12
10859 ! diagnostics only
10860 !      eom1=0.0d0
10861 !      eom2=0.0d0
10862 !      eom12=evdwij*eps1_om12
10863 ! end diagnostics
10864 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
10865 !       " sigder",sigder
10866 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
10867 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
10868 !C      print *,sss_ele_cut,'in sc_grad'
10869       do k=1,3
10870         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
10871         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
10872       enddo
10873       do k=1,3
10874         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
10875 !C      print *,'gg',k,gg(k)
10876        enddo
10877 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
10878 !      write (iout,*) "gg",(gg(k),k=1,3)
10879       do k=1,3
10880         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
10881                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10882                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
10883                   *sss_ele_cut
10884
10885         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
10886                   +(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                   *sss_ele_cut
10889
10890 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
10891 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
10892 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
10893 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
10894       enddo
10895 !
10896 ! Calculate the components of the gradient in DC and X
10897 !
10898 !grad      do k=i,j-1
10899 !grad        do l=1,3
10900 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
10901 !grad        enddo
10902 !grad      enddo
10903       do l=1,3
10904         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
10905         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
10906       enddo
10907       return
10908       end subroutine sc_grad
10909 #ifdef CRYST_THETA
10910 !-----------------------------------------------------------------------------
10911       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
10912
10913       use comm_calcthet
10914 !      implicit real*8 (a-h,o-z)
10915 !      include 'DIMENSIONS'
10916 !      include 'COMMON.LOCAL'
10917 !      include 'COMMON.IOUNITS'
10918 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
10919 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10920 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
10921       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
10922       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
10923 !el      integer :: it
10924 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
10925 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
10926 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
10927 !el local variables
10928
10929       delthec=thetai-thet_pred_mean
10930       delthe0=thetai-theta0i
10931 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
10932       t3 = thetai-thet_pred_mean
10933       t6 = t3**2
10934       t9 = term1
10935       t12 = t3*sigcsq
10936       t14 = t12+t6*sigsqtc
10937       t16 = 1.0d0
10938       t21 = thetai-theta0i
10939       t23 = t21**2
10940       t26 = term2
10941       t27 = t21*t26
10942       t32 = termexp
10943       t40 = t32**2
10944       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
10945        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
10946        *(-t12*t9-ak*sig0inv*t27)
10947       return
10948       end subroutine mixder
10949 #endif
10950 !-----------------------------------------------------------------------------
10951 ! cartder.F
10952 !-----------------------------------------------------------------------------
10953       subroutine cartder
10954 !-----------------------------------------------------------------------------
10955 ! This subroutine calculates the derivatives of the consecutive virtual
10956 ! bond vectors and the SC vectors in the virtual-bond angles theta and
10957 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
10958 ! in the angles alpha and omega, describing the location of a side chain
10959 ! in its local coordinate system.
10960 !
10961 ! The derivatives are stored in the following arrays:
10962 !
10963 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
10964 ! The structure is as follows:
10965 !
10966 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
10967 ! 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)
10968 !         . . . . . . . . . . . .  . . . . . .
10969 ! 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)
10970 !                          .
10971 !                          .
10972 !                          .
10973 ! 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)
10974 !
10975 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
10976 ! The structure is same as above.
10977 !
10978 ! DCDS - the derivatives of the side chain vectors in the local spherical
10979 ! andgles alph and omega:
10980 !
10981 ! 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)
10982 ! 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)
10983 !                          .
10984 !                          .
10985 !                          .
10986 ! 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)
10987 !
10988 ! Version of March '95, based on an early version of November '91.
10989 !
10990 !**********************************************************************
10991 !      implicit real*8 (a-h,o-z)
10992 !      include 'DIMENSIONS'
10993 !      include 'COMMON.VAR'
10994 !      include 'COMMON.CHAIN'
10995 !      include 'COMMON.DERIV'
10996 !      include 'COMMON.GEO'
10997 !      include 'COMMON.LOCAL'
10998 !      include 'COMMON.INTERACT'
10999       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11000       real(kind=8),dimension(3,3) :: dp,temp
11001 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11002       real(kind=8),dimension(3) :: xx,xx1
11003 !el local variables
11004       integer :: i,k,l,j,m,ind,ind1,jjj
11005       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11006                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11007                  sint2,xp,yp,xxp,yyp,zzp,dj
11008
11009 !      common /przechowalnia/ fromto
11010       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11011 ! get the position of the jth ijth fragment of the chain coordinate system
11012 ! in the fromto array.
11013 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11014 !
11015 !      maxdim=(nres-1)*(nres-2)/2
11016 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11017 ! calculate the derivatives of transformation matrix elements in theta
11018 !
11019
11020 !el      call flush(iout) !el
11021       do i=1,nres-2
11022         rdt(1,1,i)=-rt(1,2,i)
11023         rdt(1,2,i)= rt(1,1,i)
11024         rdt(1,3,i)= 0.0d0
11025         rdt(2,1,i)=-rt(2,2,i)
11026         rdt(2,2,i)= rt(2,1,i)
11027         rdt(2,3,i)= 0.0d0
11028         rdt(3,1,i)=-rt(3,2,i)
11029         rdt(3,2,i)= rt(3,1,i)
11030         rdt(3,3,i)= 0.0d0
11031       enddo
11032 !
11033 ! derivatives in phi
11034 !
11035       do i=2,nres-2
11036         drt(1,1,i)= 0.0d0
11037         drt(1,2,i)= 0.0d0
11038         drt(1,3,i)= 0.0d0
11039         drt(2,1,i)= rt(3,1,i)
11040         drt(2,2,i)= rt(3,2,i)
11041         drt(2,3,i)= rt(3,3,i)
11042         drt(3,1,i)=-rt(2,1,i)
11043         drt(3,2,i)=-rt(2,2,i)
11044         drt(3,3,i)=-rt(2,3,i)
11045       enddo
11046 !
11047 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11048 !
11049       do i=2,nres-2
11050         ind=indmat(i,i+1)
11051         do k=1,3
11052           do l=1,3
11053             temp(k,l)=rt(k,l,i)
11054           enddo
11055         enddo
11056         do k=1,3
11057           do l=1,3
11058             fromto(k,l,ind)=temp(k,l)
11059           enddo
11060         enddo
11061         do j=i+1,nres-2
11062           ind=indmat(i,j+1)
11063           do k=1,3
11064             do l=1,3
11065               dpkl=0.0d0
11066               do m=1,3
11067                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11068               enddo
11069               dp(k,l)=dpkl
11070               fromto(k,l,ind)=dpkl
11071             enddo
11072           enddo
11073           do k=1,3
11074             do l=1,3
11075               temp(k,l)=dp(k,l)
11076             enddo
11077           enddo
11078         enddo
11079       enddo
11080 !
11081 ! Calculate derivatives.
11082 !
11083       ind1=0
11084       do i=1,nres-2
11085         ind1=ind1+1
11086 !
11087 ! Derivatives of DC(i+1) in theta(i+2)
11088 !
11089         do j=1,3
11090           do k=1,2
11091             dpjk=0.0D0
11092             do l=1,3
11093               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11094             enddo
11095             dp(j,k)=dpjk
11096             prordt(j,k,i)=dp(j,k)
11097           enddo
11098           dp(j,3)=0.0D0
11099           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11100         enddo
11101 !
11102 ! Derivatives of SC(i+1) in theta(i+2)
11103 !
11104         xx1(1)=-0.5D0*xloc(2,i+1)
11105         xx1(2)= 0.5D0*xloc(1,i+1)
11106         do j=1,3
11107           xj=0.0D0
11108           do k=1,2
11109             xj=xj+r(j,k,i)*xx1(k)
11110           enddo
11111           xx(j)=xj
11112         enddo
11113         do j=1,3
11114           rj=0.0D0
11115           do k=1,3
11116             rj=rj+prod(j,k,i)*xx(k)
11117           enddo
11118           dxdv(j,ind1)=rj
11119         enddo
11120 !
11121 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11122 ! than the other off-diagonal derivatives.
11123 !
11124         do j=1,3
11125           dxoiij=0.0D0
11126           do k=1,3
11127             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11128           enddo
11129           dxdv(j,ind1+1)=dxoiij
11130         enddo
11131 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11132 !
11133 ! Derivatives of DC(i+1) in phi(i+2)
11134 !
11135         do j=1,3
11136           do k=1,3
11137             dpjk=0.0
11138             do l=2,3
11139               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11140             enddo
11141             dp(j,k)=dpjk
11142             prodrt(j,k,i)=dp(j,k)
11143           enddo
11144           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11145         enddo
11146 !
11147 ! Derivatives of SC(i+1) in phi(i+2)
11148 !
11149         xx(1)= 0.0D0
11150         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11151         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11152         do j=1,3
11153           rj=0.0D0
11154           do k=2,3
11155             rj=rj+prod(j,k,i)*xx(k)
11156           enddo
11157           dxdv(j+3,ind1)=-rj
11158         enddo
11159 !
11160 ! Derivatives of SC(i+1) in phi(i+3).
11161 !
11162         do j=1,3
11163           dxoiij=0.0D0
11164           do k=1,3
11165             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11166           enddo
11167           dxdv(j+3,ind1+1)=dxoiij
11168         enddo
11169 !
11170 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11171 ! theta(nres) and phi(i+3) thru phi(nres).
11172 !
11173         do j=i+1,nres-2
11174           ind1=ind1+1
11175           ind=indmat(i+1,j+1)
11176 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11177           do k=1,3
11178             do l=1,3
11179               tempkl=0.0D0
11180               do m=1,2
11181                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11182               enddo
11183               temp(k,l)=tempkl
11184             enddo
11185           enddo
11186 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11187 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11188 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11189 ! Derivatives of virtual-bond vectors in theta
11190           do k=1,3
11191             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11192           enddo
11193 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11194 ! Derivatives of SC vectors in theta
11195           do k=1,3
11196             dxoijk=0.0D0
11197             do l=1,3
11198               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11199             enddo
11200             dxdv(k,ind1+1)=dxoijk
11201           enddo
11202 !
11203 !--- Calculate the derivatives in phi
11204 !
11205           do k=1,3
11206             do l=1,3
11207               tempkl=0.0D0
11208               do m=1,3
11209                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11210               enddo
11211               temp(k,l)=tempkl
11212             enddo
11213           enddo
11214           do k=1,3
11215             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11216           enddo
11217           do k=1,3
11218             dxoijk=0.0D0
11219             do l=1,3
11220               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11221             enddo
11222             dxdv(k+3,ind1+1)=dxoijk
11223           enddo
11224         enddo
11225       enddo
11226 !
11227 ! Derivatives in alpha and omega:
11228 !
11229       do i=2,nres-1
11230 !       dsci=dsc(itype(i,1))
11231         dsci=vbld(i+nres)
11232 #ifdef OSF
11233         alphi=alph(i)
11234         omegi=omeg(i)
11235         if(alphi.ne.alphi) alphi=100.0
11236         if(omegi.ne.omegi) omegi=-100.0
11237 #else
11238         alphi=alph(i)
11239         omegi=omeg(i)
11240 #endif
11241 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11242         cosalphi=dcos(alphi)
11243         sinalphi=dsin(alphi)
11244         cosomegi=dcos(omegi)
11245         sinomegi=dsin(omegi)
11246         temp(1,1)=-dsci*sinalphi
11247         temp(2,1)= dsci*cosalphi*cosomegi
11248         temp(3,1)=-dsci*cosalphi*sinomegi
11249         temp(1,2)=0.0D0
11250         temp(2,2)=-dsci*sinalphi*sinomegi
11251         temp(3,2)=-dsci*sinalphi*cosomegi
11252         theta2=pi-0.5D0*theta(i+1)
11253         cost2=dcos(theta2)
11254         sint2=dsin(theta2)
11255         jjj=0
11256 !d      print *,((temp(l,k),l=1,3),k=1,2)
11257         do j=1,2
11258           xp=temp(1,j)
11259           yp=temp(2,j)
11260           xxp= xp*cost2+yp*sint2
11261           yyp=-xp*sint2+yp*cost2
11262           zzp=temp(3,j)
11263           xx(1)=xxp
11264           xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11265           xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11266           do k=1,3
11267             dj=0.0D0
11268             do l=1,3
11269               dj=dj+prod(k,l,i-1)*xx(l)
11270             enddo
11271             dxds(jjj+k,i)=dj
11272           enddo
11273           jjj=jjj+3
11274         enddo
11275       enddo
11276       return
11277       end subroutine cartder
11278 !-----------------------------------------------------------------------------
11279 ! checkder_p.F
11280 !-----------------------------------------------------------------------------
11281       subroutine check_cartgrad
11282 ! Check the gradient of Cartesian coordinates in internal coordinates.
11283 !      implicit real*8 (a-h,o-z)
11284 !      include 'DIMENSIONS'
11285 !      include 'COMMON.IOUNITS'
11286 !      include 'COMMON.VAR'
11287 !      include 'COMMON.CHAIN'
11288 !      include 'COMMON.GEO'
11289 !      include 'COMMON.LOCAL'
11290 !      include 'COMMON.DERIV'
11291       real(kind=8),dimension(6,nres) :: temp
11292       real(kind=8),dimension(3) :: xx,gg
11293       integer :: i,k,j,ii
11294       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11295 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11296 !
11297 ! Check the gradient of the virtual-bond and SC vectors in the internal
11298 ! coordinates.
11299 !
11300       aincr=1.0d-6
11301       aincr2=5.0d-7
11302       call cartder
11303       write (iout,'(a)') '**************** dx/dalpha'
11304       write (iout,'(a)')
11305       do i=2,nres-1
11306         alphi=alph(i)
11307         alph(i)=alph(i)+aincr
11308         do k=1,3
11309           temp(k,i)=dc(k,nres+i)
11310         enddo
11311         call chainbuild
11312         do k=1,3
11313           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11314           xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11315         enddo
11316         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11317         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11318         write (iout,'(a)')
11319         alph(i)=alphi
11320         call chainbuild
11321       enddo
11322       write (iout,'(a)')
11323       write (iout,'(a)') '**************** dx/domega'
11324       write (iout,'(a)')
11325       do i=2,nres-1
11326         omegi=omeg(i)
11327         omeg(i)=omeg(i)+aincr
11328         do k=1,3
11329           temp(k,i)=dc(k,nres+i)
11330         enddo
11331         call chainbuild
11332         do k=1,3
11333           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11334           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11335                 (aincr*dabs(dxds(k+3,i))+aincr))
11336         enddo
11337         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11338             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11339         write (iout,'(a)')
11340         omeg(i)=omegi
11341         call chainbuild
11342       enddo
11343       write (iout,'(a)')
11344       write (iout,'(a)') '**************** dx/dtheta'
11345       write (iout,'(a)')
11346       do i=3,nres
11347         theti=theta(i)
11348         theta(i)=theta(i)+aincr
11349         do j=i-1,nres-1
11350           do k=1,3
11351             temp(k,j)=dc(k,nres+j)
11352           enddo
11353         enddo
11354         call chainbuild
11355         do j=i-1,nres-1
11356           ii = indmat(i-2,j)
11357 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11358           do k=1,3
11359             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11360             xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11361                   (aincr*dabs(dxdv(k,ii))+aincr))
11362           enddo
11363           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11364               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11365           write(iout,'(a)')
11366         enddo
11367         write (iout,'(a)')
11368         theta(i)=theti
11369         call chainbuild
11370       enddo
11371       write (iout,'(a)') '***************** dx/dphi'
11372       write (iout,'(a)')
11373       do i=4,nres
11374         phi(i)=phi(i)+aincr
11375         do j=i-1,nres-1
11376           do k=1,3
11377             temp(k,j)=dc(k,nres+j)
11378           enddo
11379         enddo
11380         call chainbuild
11381         do j=i-1,nres-1
11382           ii = indmat(i-2,j)
11383 !         print *,'ii=',ii
11384           do k=1,3
11385             gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11386             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11387                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11388           enddo
11389           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11390               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11391           write(iout,'(a)')
11392         enddo
11393         phi(i)=phi(i)-aincr
11394         call chainbuild
11395       enddo
11396       write (iout,'(a)') '****************** ddc/dtheta'
11397       do i=1,nres-2
11398         thet=theta(i+2)
11399         theta(i+2)=thet+aincr
11400         do j=i,nres
11401           do k=1,3
11402             temp(k,j)=dc(k,j)
11403           enddo
11404         enddo
11405         call chainbuild
11406         do j=i+1,nres-1
11407           ii = indmat(i,j)
11408 !         print *,'ii=',ii
11409           do k=1,3
11410             gg(k)=(dc(k,j)-temp(k,j))/aincr
11411             xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11412                  (aincr*dabs(dcdv(k,ii))+aincr))
11413           enddo
11414           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11415                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11416           write (iout,'(a)')
11417         enddo
11418         do j=1,nres
11419           do k=1,3
11420             dc(k,j)=temp(k,j)
11421           enddo
11422         enddo
11423         theta(i+2)=thet
11424       enddo
11425       write (iout,'(a)') '******************* ddc/dphi'
11426       do i=1,nres-3
11427         phii=phi(i+3)
11428         phi(i+3)=phii+aincr
11429         do j=1,nres
11430           do k=1,3
11431             temp(k,j)=dc(k,j)
11432           enddo
11433         enddo
11434         call chainbuild
11435         do j=i+2,nres-1
11436           ii = indmat(i+1,j)
11437 !         print *,'ii=',ii
11438           do k=1,3
11439             gg(k)=(dc(k,j)-temp(k,j))/aincr
11440             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11441                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11442           enddo
11443           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11444                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11445           write (iout,'(a)')
11446         enddo
11447         do j=1,nres
11448           do k=1,3
11449             dc(k,j)=temp(k,j)
11450           enddo
11451         enddo
11452         phi(i+3)=phii
11453       enddo
11454       return
11455       end subroutine check_cartgrad
11456 !-----------------------------------------------------------------------------
11457       subroutine check_ecart
11458 ! Check the gradient of the energy in Cartesian coordinates.
11459 !     implicit real*8 (a-h,o-z)
11460 !     include 'DIMENSIONS'
11461 !     include 'COMMON.CHAIN'
11462 !     include 'COMMON.DERIV'
11463 !     include 'COMMON.IOUNITS'
11464 !     include 'COMMON.VAR'
11465 !     include 'COMMON.CONTACTS'
11466       use comm_srutu
11467 !el      integer :: icall
11468 !el      common /srutu/ icall
11469       real(kind=8),dimension(6) :: ggg
11470       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11471       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11472       real(kind=8),dimension(6,nres) :: grad_s
11473       real(kind=8),dimension(0:n_ene) :: energia,energia1
11474       integer :: uiparm(1)
11475       real(kind=8) :: urparm(1)
11476 !EL      external fdum
11477       integer :: nf,i,j,k
11478       real(kind=8) :: aincr,etot,etot1
11479       icg=1
11480       nf=0
11481       nfl=0
11482       call zerograd
11483       aincr=1.0D-5
11484       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11485       nf=0
11486       icall=0
11487       call geom_to_var(nvar,x)
11488       call etotal(energia)
11489       etot=energia(0)
11490 !el      call enerprint(energia)
11491       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11492       icall =1
11493       do i=1,nres
11494         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11495       enddo
11496       do i=1,nres
11497         do j=1,3
11498           grad_s(j,i)=gradc(j,i,icg)
11499           grad_s(j+3,i)=gradx(j,i,icg)
11500         enddo
11501       enddo
11502       call flush(iout)
11503       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11504       do i=1,nres
11505         do j=1,3
11506           xx(j)=c(j,i+nres)
11507           ddc(j)=dc(j,i)
11508           ddx(j)=dc(j,i+nres)
11509         enddo
11510         do j=1,3
11511           dc(j,i)=dc(j,i)+aincr
11512           do k=i+1,nres
11513             c(j,k)=c(j,k)+aincr
11514             c(j,k+nres)=c(j,k+nres)+aincr
11515           enddo
11516           call etotal(energia1)
11517           etot1=energia1(0)
11518           ggg(j)=(etot1-etot)/aincr
11519           dc(j,i)=ddc(j)
11520           do k=i+1,nres
11521             c(j,k)=c(j,k)-aincr
11522             c(j,k+nres)=c(j,k+nres)-aincr
11523           enddo
11524         enddo
11525         do j=1,3
11526           c(j,i+nres)=c(j,i+nres)+aincr
11527           dc(j,i+nres)=dc(j,i+nres)+aincr
11528           call etotal(energia1)
11529           etot1=energia1(0)
11530           ggg(j+3)=(etot1-etot)/aincr
11531           c(j,i+nres)=xx(j)
11532           dc(j,i+nres)=ddx(j)
11533         enddo
11534         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11535          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11536       enddo
11537       return
11538       end subroutine check_ecart
11539 #ifdef CARGRAD
11540 !-----------------------------------------------------------------------------
11541       subroutine check_ecartint
11542 ! Check the gradient of the energy in Cartesian coordinates.
11543       use io_base, only: intout
11544 !      implicit real*8 (a-h,o-z)
11545 !      include 'DIMENSIONS'
11546 !      include 'COMMON.CONTROL'
11547 !      include 'COMMON.CHAIN'
11548 !      include 'COMMON.DERIV'
11549 !      include 'COMMON.IOUNITS'
11550 !      include 'COMMON.VAR'
11551 !      include 'COMMON.CONTACTS'
11552 !      include 'COMMON.MD'
11553 !      include 'COMMON.LOCAL'
11554 !      include 'COMMON.SPLITELE'
11555       use comm_srutu
11556 !el      integer :: icall
11557 !el      common /srutu/ icall
11558       real(kind=8),dimension(6) :: ggg,ggg1
11559       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11560       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11561       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11562       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11563       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11564       real(kind=8),dimension(0:n_ene) :: energia,energia1
11565       integer :: uiparm(1)
11566       real(kind=8) :: urparm(1)
11567 !EL      external fdum
11568       integer :: i,j,k,nf
11569       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11570                    etot21,etot22
11571       r_cut=2.0d0
11572       rlambd=0.3d0
11573       icg=1
11574       nf=0
11575       nfl=0
11576       call intout
11577 !      call intcartderiv
11578 !      call checkintcartgrad
11579       call zerograd
11580       aincr=1.0D-5
11581       write(iout,*) 'Calling CHECK_ECARTINT.'
11582       nf=0
11583       icall=0
11584       write (iout,*) "Before geom_to_var"
11585       call geom_to_var(nvar,x)
11586       write (iout,*) "after geom_to_var"
11587       write (iout,*) "split_ene ",split_ene
11588       call flush(iout)
11589       if (.not.split_ene) then
11590         write(iout,*) 'Calling CHECK_ECARTINT if'
11591         call etotal(energia)
11592 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11593         etot=energia(0)
11594         write (iout,*) "etot",etot
11595         call flush(iout)
11596 !el        call enerprint(energia)
11597 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11598         call flush(iout)
11599         write (iout,*) "enter cartgrad"
11600         call flush(iout)
11601         call cartgrad
11602 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11603         write (iout,*) "exit cartgrad"
11604         call flush(iout)
11605         icall =1
11606         do i=1,nres
11607           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11608         enddo
11609         do j=1,3
11610           grad_s(j,0)=gcart(j,0)
11611         enddo
11612 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11613         do i=1,nres
11614           do j=1,3
11615             grad_s(j,i)=gcart(j,i)
11616             grad_s(j+3,i)=gxcart(j,i)
11617           enddo
11618         enddo
11619       else
11620 write(iout,*) 'Calling CHECK_ECARTIN else.'
11621 !- split gradient check
11622         call zerograd
11623         call etotal_long(energia)
11624 !el        call enerprint(energia)
11625         call flush(iout)
11626         write (iout,*) "enter cartgrad"
11627         call flush(iout)
11628         call cartgrad
11629         write (iout,*) "exit cartgrad"
11630         call flush(iout)
11631         icall =1
11632         write (iout,*) "longrange grad"
11633         do i=1,nres
11634           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11635           (gxcart(j,i),j=1,3)
11636         enddo
11637         do j=1,3
11638           grad_s(j,0)=gcart(j,0)
11639         enddo
11640         do i=1,nres
11641           do j=1,3
11642             grad_s(j,i)=gcart(j,i)
11643             grad_s(j+3,i)=gxcart(j,i)
11644           enddo
11645         enddo
11646         call zerograd
11647         call etotal_short(energia)
11648 !el        call enerprint(energia)
11649         call flush(iout)
11650         write (iout,*) "enter cartgrad"
11651         call flush(iout)
11652         call cartgrad
11653         write (iout,*) "exit cartgrad"
11654         call flush(iout)
11655         icall =1
11656         write (iout,*) "shortrange grad"
11657         do i=1,nres
11658           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11659           (gxcart(j,i),j=1,3)
11660         enddo
11661         do j=1,3
11662           grad_s1(j,0)=gcart(j,0)
11663         enddo
11664         do i=1,nres
11665           do j=1,3
11666             grad_s1(j,i)=gcart(j,i)
11667             grad_s1(j+3,i)=gxcart(j,i)
11668           enddo
11669         enddo
11670       endif
11671       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11672 !      do i=1,nres
11673       do i=nnt,nct
11674         do j=1,3
11675           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11676           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11677           ddc(j)=c(j,i)
11678           ddx(j)=c(j,i+nres)
11679           dcnorm_safe1(j)=dc_norm(j,i-1)
11680           dcnorm_safe2(j)=dc_norm(j,i)
11681           dxnorm_safe(j)=dc_norm(j,i+nres)
11682         enddo
11683         do j=1,3
11684           c(j,i)=ddc(j)+aincr
11685           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11686           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11687           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11688           dc(j,i)=c(j,i+1)-c(j,i)
11689           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11690           call int_from_cart1(.false.)
11691           if (.not.split_ene) then
11692             call etotal(energia1)
11693             etot1=energia1(0)
11694             write (iout,*) "ij",i,j," etot1",etot1
11695           else
11696 !- split gradient
11697             call etotal_long(energia1)
11698             etot11=energia1(0)
11699             call etotal_short(energia1)
11700             etot12=energia1(0)
11701           endif
11702 !- end split gradient
11703 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11704           c(j,i)=ddc(j)-aincr
11705           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11706           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11707           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11708           dc(j,i)=c(j,i+1)-c(j,i)
11709           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11710           call int_from_cart1(.false.)
11711           if (.not.split_ene) then
11712             call etotal(energia1)
11713             etot2=energia1(0)
11714             write (iout,*) "ij",i,j," etot2",etot2
11715             ggg(j)=(etot1-etot2)/(2*aincr)
11716           else
11717 !- split gradient
11718             call etotal_long(energia1)
11719             etot21=energia1(0)
11720             ggg(j)=(etot11-etot21)/(2*aincr)
11721             call etotal_short(energia1)
11722             etot22=energia1(0)
11723             ggg1(j)=(etot12-etot22)/(2*aincr)
11724 !- end split gradient
11725 !            write (iout,*) "etot21",etot21," etot22",etot22
11726           endif
11727 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11728           c(j,i)=ddc(j)
11729           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11730           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11731           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11732           dc(j,i)=c(j,i+1)-c(j,i)
11733           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11734           dc_norm(j,i-1)=dcnorm_safe1(j)
11735           dc_norm(j,i)=dcnorm_safe2(j)
11736           dc_norm(j,i+nres)=dxnorm_safe(j)
11737         enddo
11738         do j=1,3
11739           c(j,i+nres)=ddx(j)+aincr
11740           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11741           call int_from_cart1(.false.)
11742           if (.not.split_ene) then
11743             call etotal(energia1)
11744             etot1=energia1(0)
11745           else
11746 !- split gradient
11747             call etotal_long(energia1)
11748             etot11=energia1(0)
11749             call etotal_short(energia1)
11750             etot12=energia1(0)
11751           endif
11752 !- end split gradient
11753           c(j,i+nres)=ddx(j)-aincr
11754           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11755           call int_from_cart1(.false.)
11756           if (.not.split_ene) then
11757             call etotal(energia1)
11758             etot2=energia1(0)
11759             ggg(j+3)=(etot1-etot2)/(2*aincr)
11760           else
11761 !- split gradient
11762             call etotal_long(energia1)
11763             etot21=energia1(0)
11764             ggg(j+3)=(etot11-etot21)/(2*aincr)
11765             call etotal_short(energia1)
11766             etot22=energia1(0)
11767             ggg1(j+3)=(etot12-etot22)/(2*aincr)
11768 !- end split gradient
11769           endif
11770 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11771           c(j,i+nres)=ddx(j)
11772           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11773           dc_norm(j,i+nres)=dxnorm_safe(j)
11774           call int_from_cart1(.false.)
11775         enddo
11776         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11777          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11778         if (split_ene) then
11779           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11780          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11781          k=1,6)
11782          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11783          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11784          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11785         endif
11786       enddo
11787       return
11788       end subroutine check_ecartint
11789 #else
11790 !-----------------------------------------------------------------------------
11791       subroutine check_ecartint
11792 ! Check the gradient of the energy in Cartesian coordinates.
11793       use io_base, only: intout
11794 !      implicit real*8 (a-h,o-z)
11795 !      include 'DIMENSIONS'
11796 !      include 'COMMON.CONTROL'
11797 !      include 'COMMON.CHAIN'
11798 !      include 'COMMON.DERIV'
11799 !      include 'COMMON.IOUNITS'
11800 !      include 'COMMON.VAR'
11801 !      include 'COMMON.CONTACTS'
11802 !      include 'COMMON.MD'
11803 !      include 'COMMON.LOCAL'
11804 !      include 'COMMON.SPLITELE'
11805       use comm_srutu
11806 !el      integer :: icall
11807 !el      common /srutu/ icall
11808       real(kind=8),dimension(6) :: ggg,ggg1
11809       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11810       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11811       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
11812       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11813       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11814       real(kind=8),dimension(0:n_ene) :: energia,energia1
11815       integer :: uiparm(1)
11816       real(kind=8) :: urparm(1)
11817 !EL      external fdum
11818       integer :: i,j,k,nf
11819       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11820                    etot21,etot22
11821       r_cut=2.0d0
11822       rlambd=0.3d0
11823       icg=1
11824       nf=0
11825       nfl=0
11826       call intout
11827 !      call intcartderiv
11828 !      call checkintcartgrad
11829       call zerograd
11830       aincr=2.0D-5
11831       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
11832       nf=0
11833       icall=0
11834       call geom_to_var(nvar,x)
11835       if (.not.split_ene) then
11836         call etotal(energia)
11837         etot=energia(0)
11838 !el        call enerprint(energia)
11839         call flush(iout)
11840         write (iout,*) "enter cartgrad"
11841         call flush(iout)
11842         call cartgrad
11843         write (iout,*) "exit cartgrad"
11844         call flush(iout)
11845         icall =1
11846         do i=1,nres
11847           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11848         enddo
11849         do j=1,3
11850           grad_s(j,0)=gcart(j,0)
11851         enddo
11852         do i=1,nres
11853           do j=1,3
11854             grad_s(j,i)=gcart(j,i)
11855             grad_s(j+3,i)=gxcart(j,i)
11856           enddo
11857         enddo
11858       else
11859 !- split gradient check
11860         call zerograd
11861         call etotal_long(energia)
11862 !el        call enerprint(energia)
11863         call flush(iout)
11864         write (iout,*) "enter cartgrad"
11865         call flush(iout)
11866         call cartgrad
11867         write (iout,*) "exit cartgrad"
11868         call flush(iout)
11869         icall =1
11870         write (iout,*) "longrange grad"
11871         do i=1,nres
11872           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11873           (gxcart(j,i),j=1,3)
11874         enddo
11875         do j=1,3
11876           grad_s(j,0)=gcart(j,0)
11877         enddo
11878         do i=1,nres
11879           do j=1,3
11880             grad_s(j,i)=gcart(j,i)
11881             grad_s(j+3,i)=gxcart(j,i)
11882           enddo
11883         enddo
11884         call zerograd
11885         call etotal_short(energia)
11886 !el        call enerprint(energia)
11887         call flush(iout)
11888         write (iout,*) "enter cartgrad"
11889         call flush(iout)
11890         call cartgrad
11891         write (iout,*) "exit cartgrad"
11892         call flush(iout)
11893         icall =1
11894         write (iout,*) "shortrange grad"
11895         do i=1,nres
11896           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11897           (gxcart(j,i),j=1,3)
11898         enddo
11899         do j=1,3
11900           grad_s1(j,0)=gcart(j,0)
11901         enddo
11902         do i=1,nres
11903           do j=1,3
11904             grad_s1(j,i)=gcart(j,i)
11905             grad_s1(j+3,i)=gxcart(j,i)
11906           enddo
11907         enddo
11908       endif
11909       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11910       do i=0,nres
11911         do j=1,3
11912           xx(j)=c(j,i+nres)
11913           ddc(j)=dc(j,i)
11914           ddx(j)=dc(j,i+nres)
11915           do k=1,3
11916             dcnorm_safe(k)=dc_norm(k,i)
11917             dxnorm_safe(k)=dc_norm(k,i+nres)
11918           enddo
11919         enddo
11920         do j=1,3
11921           dc(j,i)=ddc(j)+aincr
11922           call chainbuild_cart
11923 #ifdef MPI
11924 ! Broadcast the order to compute internal coordinates to the slaves.
11925 !          if (nfgtasks.gt.1)
11926 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
11927 #endif
11928 !          call int_from_cart1(.false.)
11929           if (.not.split_ene) then
11930             call etotal(energia1)
11931             etot1=energia1(0)
11932           else
11933 !- split gradient
11934             call etotal_long(energia1)
11935             etot11=energia1(0)
11936             call etotal_short(energia1)
11937             etot12=energia1(0)
11938 !            write (iout,*) "etot11",etot11," etot12",etot12
11939           endif
11940 !- end split gradient
11941 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11942           dc(j,i)=ddc(j)-aincr
11943           call chainbuild_cart
11944 !          call int_from_cart1(.false.)
11945           if (.not.split_ene) then
11946             call etotal(energia1)
11947             etot2=energia1(0)
11948             ggg(j)=(etot1-etot2)/(2*aincr)
11949           else
11950 !- split gradient
11951             call etotal_long(energia1)
11952             etot21=energia1(0)
11953             ggg(j)=(etot11-etot21)/(2*aincr)
11954             call etotal_short(energia1)
11955             etot22=energia1(0)
11956             ggg1(j)=(etot12-etot22)/(2*aincr)
11957 !- end split gradient
11958 !            write (iout,*) "etot21",etot21," etot22",etot22
11959           endif
11960 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11961           dc(j,i)=ddc(j)
11962           call chainbuild_cart
11963         enddo
11964         do j=1,3
11965           dc(j,i+nres)=ddx(j)+aincr
11966           call chainbuild_cart
11967 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
11968 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11969 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11970 !          write (iout,*) "dxnormnorm",dsqrt(
11971 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11972 !          write (iout,*) "dxnormnormsafe",dsqrt(
11973 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11974 !          write (iout,*)
11975           if (.not.split_ene) then
11976             call etotal(energia1)
11977             etot1=energia1(0)
11978           else
11979 !- split gradient
11980             call etotal_long(energia1)
11981             etot11=energia1(0)
11982             call etotal_short(energia1)
11983             etot12=energia1(0)
11984           endif
11985 !- end split gradient
11986 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11987           dc(j,i+nres)=ddx(j)-aincr
11988           call chainbuild_cart
11989 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
11990 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
11991 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
11992 !          write (iout,*)
11993 !          write (iout,*) "dxnormnorm",dsqrt(
11994 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
11995 !          write (iout,*) "dxnormnormsafe",dsqrt(
11996 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
11997           if (.not.split_ene) then
11998             call etotal(energia1)
11999             etot2=energia1(0)
12000             ggg(j+3)=(etot1-etot2)/(2*aincr)
12001           else
12002 !- split gradient
12003             call etotal_long(energia1)
12004             etot21=energia1(0)
12005             ggg(j+3)=(etot11-etot21)/(2*aincr)
12006             call etotal_short(energia1)
12007             etot22=energia1(0)
12008             ggg1(j+3)=(etot12-etot22)/(2*aincr)
12009 !- end split gradient
12010           endif
12011 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12012           dc(j,i+nres)=ddx(j)
12013           call chainbuild_cart
12014         enddo
12015         write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12016          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12017         if (split_ene) then
12018           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12019          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12020          k=1,6)
12021          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12022          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12023          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12024         endif
12025       enddo
12026       return
12027       end subroutine check_ecartint
12028 #endif
12029 !-----------------------------------------------------------------------------
12030       subroutine check_eint
12031 ! Check the gradient of energy in internal coordinates.
12032 !      implicit real*8 (a-h,o-z)
12033 !      include 'DIMENSIONS'
12034 !      include 'COMMON.CHAIN'
12035 !      include 'COMMON.DERIV'
12036 !      include 'COMMON.IOUNITS'
12037 !      include 'COMMON.VAR'
12038 !      include 'COMMON.GEO'
12039       use comm_srutu
12040 !el      integer :: icall
12041 !el      common /srutu/ icall
12042       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12043       integer :: uiparm(1)
12044       real(kind=8) :: urparm(1)
12045       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12046       character(len=6) :: key
12047 !EL      external fdum
12048       integer :: i,ii,nf
12049       real(kind=8) :: xi,aincr,etot,etot1,etot2
12050       call zerograd
12051       aincr=1.0D-7
12052       print '(a)','Calling CHECK_INT.'
12053       nf=0
12054       nfl=0
12055       icg=1
12056       call geom_to_var(nvar,x)
12057       call var_to_geom(nvar,x)
12058       call chainbuild
12059       icall=1
12060       print *,'ICG=',ICG
12061       call etotal(energia)
12062       etot = energia(0)
12063 !el      call enerprint(energia)
12064       print *,'ICG=',ICG
12065 #ifdef MPL
12066       if (MyID.ne.BossID) then
12067         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12068         nf=x(nvar+1)
12069         nfl=x(nvar+2)
12070         icg=x(nvar+3)
12071       endif
12072 #endif
12073       nf=1
12074       nfl=3
12075 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12076       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12077 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12078       icall=1
12079       do i=1,nvar
12080         xi=x(i)
12081         x(i)=xi-0.5D0*aincr
12082         call var_to_geom(nvar,x)
12083         call chainbuild
12084         call etotal(energia1)
12085         etot1=energia1(0)
12086         x(i)=xi+0.5D0*aincr
12087         call var_to_geom(nvar,x)
12088         call chainbuild
12089         call etotal(energia2)
12090         etot2=energia2(0)
12091         gg(i)=(etot2-etot1)/aincr
12092         write (iout,*) i,etot1,etot2
12093         x(i)=xi
12094       enddo
12095       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12096           '     RelDiff*100% '
12097       do i=1,nvar
12098         if (i.le.nphi) then
12099           ii=i
12100           key = ' phi'
12101         else if (i.le.nphi+ntheta) then
12102           ii=i-nphi
12103           key=' theta'
12104         else if (i.le.nphi+ntheta+nside) then
12105            ii=i-(nphi+ntheta)
12106            key=' alpha'
12107         else
12108            ii=i-(nphi+ntheta+nside)
12109            key=' omega'
12110         endif
12111         write (iout,'(i3,a,i3,3(1pd16.6))') &
12112        i,key,ii,gg(i),gana(i),&
12113        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12114       enddo
12115       return
12116       end subroutine check_eint
12117 !-----------------------------------------------------------------------------
12118 ! econstr_local.F
12119 !-----------------------------------------------------------------------------
12120       subroutine Econstr_back
12121 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12122 !      implicit real*8 (a-h,o-z)
12123 !      include 'DIMENSIONS'
12124 !      include 'COMMON.CONTROL'
12125 !      include 'COMMON.VAR'
12126 !      include 'COMMON.MD'
12127       use MD_data
12128 !#ifndef LANG0
12129 !      include 'COMMON.LANGEVIN'
12130 !#else
12131 !      include 'COMMON.LANGEVIN.lang0'
12132 !#endif
12133 !      include 'COMMON.CHAIN'
12134 !      include 'COMMON.DERIV'
12135 !      include 'COMMON.GEO'
12136 !      include 'COMMON.LOCAL'
12137 !      include 'COMMON.INTERACT'
12138 !      include 'COMMON.IOUNITS'
12139 !      include 'COMMON.NAMES'
12140 !      include 'COMMON.TIME1'
12141       integer :: i,j,ii,k
12142       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12143
12144       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12145       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12146       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12147
12148       Uconst_back=0.0d0
12149       do i=1,nres
12150         dutheta(i)=0.0d0
12151         dugamma(i)=0.0d0
12152         do j=1,3
12153           duscdiff(j,i)=0.0d0
12154           duscdiffx(j,i)=0.0d0
12155         enddo
12156       enddo
12157       do i=1,nfrag_back
12158         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12159 !
12160 ! Deviations from theta angles
12161 !
12162         utheta_i=0.0d0
12163         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12164           dtheta_i=theta(j)-thetaref(j)
12165           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12166           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12167         enddo
12168         utheta(i)=utheta_i/(ii-1)
12169 !
12170 ! Deviations from gamma angles
12171 !
12172         ugamma_i=0.0d0
12173         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12174           dgamma_i=pinorm(phi(j)-phiref(j))
12175 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12176           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12177           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12178 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12179         enddo
12180         ugamma(i)=ugamma_i/(ii-2)
12181 !
12182 ! Deviations from local SC geometry
12183 !
12184         uscdiff(i)=0.0d0
12185         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12186           dxx=xxtab(j)-xxref(j)
12187           dyy=yytab(j)-yyref(j)
12188           dzz=zztab(j)-zzref(j)
12189           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12190           do k=1,3
12191             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12192              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12193              (ii-1)
12194             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12195              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12196              (ii-1)
12197             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12198            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12199             /(ii-1)
12200           enddo
12201 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12202 !     &      xxref(j),yyref(j),zzref(j)
12203         enddo
12204         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12205 !        write (iout,*) i," uscdiff",uscdiff(i)
12206 !
12207 ! Put together deviations from local geometry
12208 !
12209         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12210           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12211 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12212 !     &   " uconst_back",uconst_back
12213         utheta(i)=dsqrt(utheta(i))
12214         ugamma(i)=dsqrt(ugamma(i))
12215         uscdiff(i)=dsqrt(uscdiff(i))
12216       enddo
12217       return
12218       end subroutine Econstr_back
12219 !-----------------------------------------------------------------------------
12220 ! energy_p_new-sep_barrier.F
12221 !-----------------------------------------------------------------------------
12222       real(kind=8) function sscale(r)
12223 !      include "COMMON.SPLITELE"
12224       real(kind=8) :: r,gamm
12225       if(r.lt.r_cut-rlamb) then
12226         sscale=1.0d0
12227       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12228         gamm=(r-(r_cut-rlamb))/rlamb
12229         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12230       else
12231         sscale=0d0
12232       endif
12233       return
12234       end function sscale
12235       real(kind=8) function sscale_grad(r)
12236 !      include "COMMON.SPLITELE"
12237       real(kind=8) :: r,gamm
12238       if(r.lt.r_cut-rlamb) then
12239         sscale_grad=0.0d0
12240       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12241         gamm=(r-(r_cut-rlamb))/rlamb
12242         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12243       else
12244         sscale_grad=0d0
12245       endif
12246       return
12247       end function sscale_grad
12248
12249 !!!!!!!!!! PBCSCALE
12250       real(kind=8) function sscale_ele(r)
12251 !      include "COMMON.SPLITELE"
12252       real(kind=8) :: r,gamm
12253       if(r.lt.r_cut_ele-rlamb_ele) then
12254         sscale_ele=1.0d0
12255       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12256         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12257         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12258       else
12259         sscale_ele=0d0
12260       endif
12261       return
12262       end function sscale_ele
12263
12264       real(kind=8)  function sscagrad_ele(r)
12265       real(kind=8) :: r,gamm
12266 !      include "COMMON.SPLITELE"
12267       if(r.lt.r_cut_ele-rlamb_ele) then
12268         sscagrad_ele=0.0d0
12269       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12270         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12271         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12272       else
12273         sscagrad_ele=0.0d0
12274       endif
12275       return
12276       end function sscagrad_ele
12277       real(kind=8) function sscalelip(r)
12278       real(kind=8) r,gamm
12279         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12280       return
12281       end function sscalelip
12282 !C-----------------------------------------------------------------------
12283       real(kind=8) function sscagradlip(r)
12284       real(kind=8) r,gamm
12285         sscagradlip=r*(6.0d0*r-6.0d0)
12286       return
12287       end function sscagradlip
12288
12289 !!!!!!!!!!!!!!!
12290 !-----------------------------------------------------------------------------
12291       subroutine elj_long(evdw)
12292 !
12293 ! This subroutine calculates the interaction energy of nonbonded side chains
12294 ! assuming the LJ potential of interaction.
12295 !
12296 !      implicit real*8 (a-h,o-z)
12297 !      include 'DIMENSIONS'
12298 !      include 'COMMON.GEO'
12299 !      include 'COMMON.VAR'
12300 !      include 'COMMON.LOCAL'
12301 !      include 'COMMON.CHAIN'
12302 !      include 'COMMON.DERIV'
12303 !      include 'COMMON.INTERACT'
12304 !      include 'COMMON.TORSION'
12305 !      include 'COMMON.SBRIDGE'
12306 !      include 'COMMON.NAMES'
12307 !      include 'COMMON.IOUNITS'
12308 !      include 'COMMON.CONTACTS'
12309       real(kind=8),parameter :: accur=1.0d-10
12310       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12311 !el local variables
12312       integer :: i,iint,j,k,itypi,itypi1,itypj
12313       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12314       real(kind=8) :: e1,e2,evdwij,evdw
12315 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12316       evdw=0.0D0
12317       do i=iatsc_s,iatsc_e
12318         itypi=itype(i,1)
12319         if (itypi.eq.ntyp1) cycle
12320         itypi1=itype(i+1,1)
12321         xi=c(1,nres+i)
12322         yi=c(2,nres+i)
12323         zi=c(3,nres+i)
12324 !
12325 ! Calculate SC interaction energy.
12326 !
12327         do iint=1,nint_gr(i)
12328 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12329 !d   &                  'iend=',iend(i,iint)
12330           do j=istart(i,iint),iend(i,iint)
12331             itypj=itype(j,1)
12332             if (itypj.eq.ntyp1) cycle
12333             xj=c(1,nres+j)-xi
12334             yj=c(2,nres+j)-yi
12335             zj=c(3,nres+j)-zi
12336             rij=xj*xj+yj*yj+zj*zj
12337             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12338             if (sss.lt.1.0d0) then
12339               rrij=1.0D0/rij
12340               eps0ij=eps(itypi,itypj)
12341               fac=rrij**expon2
12342               e1=fac*fac*aa_aq(itypi,itypj)
12343               e2=fac*bb_aq(itypi,itypj)
12344               evdwij=e1+e2
12345               evdw=evdw+(1.0d0-sss)*evdwij
12346 !
12347 ! Calculate the components of the gradient in DC and X
12348 !
12349               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12350               gg(1)=xj*fac
12351               gg(2)=yj*fac
12352               gg(3)=zj*fac
12353               do k=1,3
12354                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12355                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12356                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12357                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12358               enddo
12359             endif
12360           enddo      ! j
12361         enddo        ! iint
12362       enddo          ! i
12363       do i=1,nct
12364         do j=1,3
12365           gvdwc(j,i)=expon*gvdwc(j,i)
12366           gvdwx(j,i)=expon*gvdwx(j,i)
12367         enddo
12368       enddo
12369 !******************************************************************************
12370 !
12371 !                              N O T E !!!
12372 !
12373 ! To save time, the factor of EXPON has been extracted from ALL components
12374 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12375 ! use!
12376 !
12377 !******************************************************************************
12378       return
12379       end subroutine elj_long
12380 !-----------------------------------------------------------------------------
12381       subroutine elj_short(evdw)
12382 !
12383 ! This subroutine calculates the interaction energy of nonbonded side chains
12384 ! assuming the LJ potential of interaction.
12385 !
12386 !      implicit real*8 (a-h,o-z)
12387 !      include 'DIMENSIONS'
12388 !      include 'COMMON.GEO'
12389 !      include 'COMMON.VAR'
12390 !      include 'COMMON.LOCAL'
12391 !      include 'COMMON.CHAIN'
12392 !      include 'COMMON.DERIV'
12393 !      include 'COMMON.INTERACT'
12394 !      include 'COMMON.TORSION'
12395 !      include 'COMMON.SBRIDGE'
12396 !      include 'COMMON.NAMES'
12397 !      include 'COMMON.IOUNITS'
12398 !      include 'COMMON.CONTACTS'
12399       real(kind=8),parameter :: accur=1.0d-10
12400       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12401 !el local variables
12402       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12403       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12404       real(kind=8) :: e1,e2,evdwij,evdw
12405 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12406       evdw=0.0D0
12407       do i=iatsc_s,iatsc_e
12408         itypi=itype(i,1)
12409         if (itypi.eq.ntyp1) cycle
12410         itypi1=itype(i+1,1)
12411         xi=c(1,nres+i)
12412         yi=c(2,nres+i)
12413         zi=c(3,nres+i)
12414 ! Change 12/1/95
12415         num_conti=0
12416 !
12417 ! Calculate SC interaction energy.
12418 !
12419         do iint=1,nint_gr(i)
12420 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12421 !d   &                  'iend=',iend(i,iint)
12422           do j=istart(i,iint),iend(i,iint)
12423             itypj=itype(j,1)
12424             if (itypj.eq.ntyp1) cycle
12425             xj=c(1,nres+j)-xi
12426             yj=c(2,nres+j)-yi
12427             zj=c(3,nres+j)-zi
12428 ! Change 12/1/95 to calculate four-body interactions
12429             rij=xj*xj+yj*yj+zj*zj
12430             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12431             if (sss.gt.0.0d0) then
12432               rrij=1.0D0/rij
12433               eps0ij=eps(itypi,itypj)
12434               fac=rrij**expon2
12435               e1=fac*fac*aa_aq(itypi,itypj)
12436               e2=fac*bb_aq(itypi,itypj)
12437               evdwij=e1+e2
12438               evdw=evdw+sss*evdwij
12439 !
12440 ! Calculate the components of the gradient in DC and X
12441 !
12442               fac=-rrij*(e1+evdwij)*sss
12443               gg(1)=xj*fac
12444               gg(2)=yj*fac
12445               gg(3)=zj*fac
12446               do k=1,3
12447                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12448                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12449                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12450                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12451               enddo
12452             endif
12453           enddo      ! j
12454         enddo        ! iint
12455       enddo          ! i
12456       do i=1,nct
12457         do j=1,3
12458           gvdwc(j,i)=expon*gvdwc(j,i)
12459           gvdwx(j,i)=expon*gvdwx(j,i)
12460         enddo
12461       enddo
12462 !******************************************************************************
12463 !
12464 !                              N O T E !!!
12465 !
12466 ! To save time, the factor of EXPON has been extracted from ALL components
12467 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12468 ! use!
12469 !
12470 !******************************************************************************
12471       return
12472       end subroutine elj_short
12473 !-----------------------------------------------------------------------------
12474       subroutine eljk_long(evdw)
12475 !
12476 ! This subroutine calculates the interaction energy of nonbonded side chains
12477 ! assuming the LJK potential of interaction.
12478 !
12479 !      implicit real*8 (a-h,o-z)
12480 !      include 'DIMENSIONS'
12481 !      include 'COMMON.GEO'
12482 !      include 'COMMON.VAR'
12483 !      include 'COMMON.LOCAL'
12484 !      include 'COMMON.CHAIN'
12485 !      include 'COMMON.DERIV'
12486 !      include 'COMMON.INTERACT'
12487 !      include 'COMMON.IOUNITS'
12488 !      include 'COMMON.NAMES'
12489       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12490       logical :: scheck
12491 !el local variables
12492       integer :: i,iint,j,k,itypi,itypi1,itypj
12493       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12494                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12495 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12496       evdw=0.0D0
12497       do i=iatsc_s,iatsc_e
12498         itypi=itype(i,1)
12499         if (itypi.eq.ntyp1) cycle
12500         itypi1=itype(i+1,1)
12501         xi=c(1,nres+i)
12502         yi=c(2,nres+i)
12503         zi=c(3,nres+i)
12504 !
12505 ! Calculate SC interaction energy.
12506 !
12507         do iint=1,nint_gr(i)
12508           do j=istart(i,iint),iend(i,iint)
12509             itypj=itype(j,1)
12510             if (itypj.eq.ntyp1) cycle
12511             xj=c(1,nres+j)-xi
12512             yj=c(2,nres+j)-yi
12513             zj=c(3,nres+j)-zi
12514             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12515             fac_augm=rrij**expon
12516             e_augm=augm(itypi,itypj)*fac_augm
12517             r_inv_ij=dsqrt(rrij)
12518             rij=1.0D0/r_inv_ij
12519             sss=sscale(rij/sigma(itypi,itypj))
12520             if (sss.lt.1.0d0) then
12521               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12522               fac=r_shift_inv**expon
12523               e1=fac*fac*aa_aq(itypi,itypj)
12524               e2=fac*bb_aq(itypi,itypj)
12525               evdwij=e_augm+e1+e2
12526 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12527 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12528 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12529 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12530 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12531 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12532 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12533               evdw=evdw+(1.0d0-sss)*evdwij
12534 !
12535 ! Calculate the components of the gradient in DC and X
12536 !
12537               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12538               fac=fac*(1.0d0-sss)
12539               gg(1)=xj*fac
12540               gg(2)=yj*fac
12541               gg(3)=zj*fac
12542               do k=1,3
12543                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12544                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12545                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12546                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12547               enddo
12548             endif
12549           enddo      ! j
12550         enddo        ! iint
12551       enddo          ! i
12552       do i=1,nct
12553         do j=1,3
12554           gvdwc(j,i)=expon*gvdwc(j,i)
12555           gvdwx(j,i)=expon*gvdwx(j,i)
12556         enddo
12557       enddo
12558       return
12559       end subroutine eljk_long
12560 !-----------------------------------------------------------------------------
12561       subroutine eljk_short(evdw)
12562 !
12563 ! This subroutine calculates the interaction energy of nonbonded side chains
12564 ! assuming the LJK potential of interaction.
12565 !
12566 !      implicit real*8 (a-h,o-z)
12567 !      include 'DIMENSIONS'
12568 !      include 'COMMON.GEO'
12569 !      include 'COMMON.VAR'
12570 !      include 'COMMON.LOCAL'
12571 !      include 'COMMON.CHAIN'
12572 !      include 'COMMON.DERIV'
12573 !      include 'COMMON.INTERACT'
12574 !      include 'COMMON.IOUNITS'
12575 !      include 'COMMON.NAMES'
12576       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12577       logical :: scheck
12578 !el local variables
12579       integer :: i,iint,j,k,itypi,itypi1,itypj
12580       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12581                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12582 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12583       evdw=0.0D0
12584       do i=iatsc_s,iatsc_e
12585         itypi=itype(i,1)
12586         if (itypi.eq.ntyp1) cycle
12587         itypi1=itype(i+1,1)
12588         xi=c(1,nres+i)
12589         yi=c(2,nres+i)
12590         zi=c(3,nres+i)
12591 !
12592 ! Calculate SC interaction energy.
12593 !
12594         do iint=1,nint_gr(i)
12595           do j=istart(i,iint),iend(i,iint)
12596             itypj=itype(j,1)
12597             if (itypj.eq.ntyp1) cycle
12598             xj=c(1,nres+j)-xi
12599             yj=c(2,nres+j)-yi
12600             zj=c(3,nres+j)-zi
12601             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12602             fac_augm=rrij**expon
12603             e_augm=augm(itypi,itypj)*fac_augm
12604             r_inv_ij=dsqrt(rrij)
12605             rij=1.0D0/r_inv_ij
12606             sss=sscale(rij/sigma(itypi,itypj))
12607             if (sss.gt.0.0d0) then
12608               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12609               fac=r_shift_inv**expon
12610               e1=fac*fac*aa_aq(itypi,itypj)
12611               e2=fac*bb_aq(itypi,itypj)
12612               evdwij=e_augm+e1+e2
12613 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12614 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12615 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12616 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12617 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12618 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12619 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12620               evdw=evdw+sss*evdwij
12621 !
12622 ! Calculate the components of the gradient in DC and X
12623 !
12624               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12625               fac=fac*sss
12626               gg(1)=xj*fac
12627               gg(2)=yj*fac
12628               gg(3)=zj*fac
12629               do k=1,3
12630                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12631                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12632                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12633                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12634               enddo
12635             endif
12636           enddo      ! j
12637         enddo        ! iint
12638       enddo          ! i
12639       do i=1,nct
12640         do j=1,3
12641           gvdwc(j,i)=expon*gvdwc(j,i)
12642           gvdwx(j,i)=expon*gvdwx(j,i)
12643         enddo
12644       enddo
12645       return
12646       end subroutine eljk_short
12647 !-----------------------------------------------------------------------------
12648       subroutine ebp_long(evdw)
12649 !
12650 ! This subroutine calculates the interaction energy of nonbonded side chains
12651 ! assuming the Berne-Pechukas potential of interaction.
12652 !
12653       use calc_data
12654 !      implicit real*8 (a-h,o-z)
12655 !      include 'DIMENSIONS'
12656 !      include 'COMMON.GEO'
12657 !      include 'COMMON.VAR'
12658 !      include 'COMMON.LOCAL'
12659 !      include 'COMMON.CHAIN'
12660 !      include 'COMMON.DERIV'
12661 !      include 'COMMON.NAMES'
12662 !      include 'COMMON.INTERACT'
12663 !      include 'COMMON.IOUNITS'
12664 !      include 'COMMON.CALC'
12665       use comm_srutu
12666 !el      integer :: icall
12667 !el      common /srutu/ icall
12668 !     double precision rrsave(maxdim)
12669       logical :: lprn
12670 !el local variables
12671       integer :: iint,itypi,itypi1,itypj
12672       real(kind=8) :: rrij,xi,yi,zi,fac
12673       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12674       evdw=0.0D0
12675 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12676       evdw=0.0D0
12677 !     if (icall.eq.0) then
12678 !       lprn=.true.
12679 !     else
12680         lprn=.false.
12681 !     endif
12682 !el      ind=0
12683       do i=iatsc_s,iatsc_e
12684         itypi=itype(i,1)
12685         if (itypi.eq.ntyp1) cycle
12686         itypi1=itype(i+1,1)
12687         xi=c(1,nres+i)
12688         yi=c(2,nres+i)
12689         zi=c(3,nres+i)
12690         dxi=dc_norm(1,nres+i)
12691         dyi=dc_norm(2,nres+i)
12692         dzi=dc_norm(3,nres+i)
12693 !        dsci_inv=dsc_inv(itypi)
12694         dsci_inv=vbld_inv(i+nres)
12695 !
12696 ! Calculate SC interaction energy.
12697 !
12698         do iint=1,nint_gr(i)
12699           do j=istart(i,iint),iend(i,iint)
12700 !el            ind=ind+1
12701             itypj=itype(j,1)
12702             if (itypj.eq.ntyp1) cycle
12703 !            dscj_inv=dsc_inv(itypj)
12704             dscj_inv=vbld_inv(j+nres)
12705             chi1=chi(itypi,itypj)
12706             chi2=chi(itypj,itypi)
12707             chi12=chi1*chi2
12708             chip1=chip(itypi)
12709             chip2=chip(itypj)
12710             chip12=chip1*chip2
12711             alf1=alp(itypi)
12712             alf2=alp(itypj)
12713             alf12=0.5D0*(alf1+alf2)
12714             xj=c(1,nres+j)-xi
12715             yj=c(2,nres+j)-yi
12716             zj=c(3,nres+j)-zi
12717             dxj=dc_norm(1,nres+j)
12718             dyj=dc_norm(2,nres+j)
12719             dzj=dc_norm(3,nres+j)
12720             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12721             rij=dsqrt(rrij)
12722             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12723
12724             if (sss.lt.1.0d0) then
12725
12726 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12727               call sc_angular
12728 ! Calculate whole angle-dependent part of epsilon and contributions
12729 ! to its derivatives
12730               fac=(rrij*sigsq)**expon2
12731               e1=fac*fac*aa_aq(itypi,itypj)
12732               e2=fac*bb_aq(itypi,itypj)
12733               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12734               eps2der=evdwij*eps3rt
12735               eps3der=evdwij*eps2rt
12736               evdwij=evdwij*eps2rt*eps3rt
12737               evdw=evdw+evdwij*(1.0d0-sss)
12738               if (lprn) then
12739               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12740               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12741 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12742 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12743 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12744 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12745 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12746 !d     &          evdwij
12747               endif
12748 ! Calculate gradient components.
12749               e1=e1*eps1*eps2rt**2*eps3rt**2
12750               fac=-expon*(e1+evdwij)
12751               sigder=fac/sigsq
12752               fac=rrij*fac
12753 ! Calculate radial part of the gradient
12754               gg(1)=xj*fac
12755               gg(2)=yj*fac
12756               gg(3)=zj*fac
12757 ! Calculate the angular part of the gradient and sum add the contributions
12758 ! to the appropriate components of the Cartesian gradient.
12759               call sc_grad_scale(1.0d0-sss)
12760             endif
12761           enddo      ! j
12762         enddo        ! iint
12763       enddo          ! i
12764 !     stop
12765       return
12766       end subroutine ebp_long
12767 !-----------------------------------------------------------------------------
12768       subroutine ebp_short(evdw)
12769 !
12770 ! This subroutine calculates the interaction energy of nonbonded side chains
12771 ! assuming the Berne-Pechukas potential of interaction.
12772 !
12773       use calc_data
12774 !      implicit real*8 (a-h,o-z)
12775 !      include 'DIMENSIONS'
12776 !      include 'COMMON.GEO'
12777 !      include 'COMMON.VAR'
12778 !      include 'COMMON.LOCAL'
12779 !      include 'COMMON.CHAIN'
12780 !      include 'COMMON.DERIV'
12781 !      include 'COMMON.NAMES'
12782 !      include 'COMMON.INTERACT'
12783 !      include 'COMMON.IOUNITS'
12784 !      include 'COMMON.CALC'
12785       use comm_srutu
12786 !el      integer :: icall
12787 !el      common /srutu/ icall
12788 !     double precision rrsave(maxdim)
12789       logical :: lprn
12790 !el local variables
12791       integer :: iint,itypi,itypi1,itypj
12792       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12793       real(kind=8) :: sss,e1,e2,evdw
12794       evdw=0.0D0
12795 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12796       evdw=0.0D0
12797 !     if (icall.eq.0) then
12798 !       lprn=.true.
12799 !     else
12800         lprn=.false.
12801 !     endif
12802 !el      ind=0
12803       do i=iatsc_s,iatsc_e
12804         itypi=itype(i,1)
12805         if (itypi.eq.ntyp1) cycle
12806         itypi1=itype(i+1,1)
12807         xi=c(1,nres+i)
12808         yi=c(2,nres+i)
12809         zi=c(3,nres+i)
12810         dxi=dc_norm(1,nres+i)
12811         dyi=dc_norm(2,nres+i)
12812         dzi=dc_norm(3,nres+i)
12813 !        dsci_inv=dsc_inv(itypi)
12814         dsci_inv=vbld_inv(i+nres)
12815 !
12816 ! Calculate SC interaction energy.
12817 !
12818         do iint=1,nint_gr(i)
12819           do j=istart(i,iint),iend(i,iint)
12820 !el            ind=ind+1
12821             itypj=itype(j,1)
12822             if (itypj.eq.ntyp1) cycle
12823 !            dscj_inv=dsc_inv(itypj)
12824             dscj_inv=vbld_inv(j+nres)
12825             chi1=chi(itypi,itypj)
12826             chi2=chi(itypj,itypi)
12827             chi12=chi1*chi2
12828             chip1=chip(itypi)
12829             chip2=chip(itypj)
12830             chip12=chip1*chip2
12831             alf1=alp(itypi)
12832             alf2=alp(itypj)
12833             alf12=0.5D0*(alf1+alf2)
12834             xj=c(1,nres+j)-xi
12835             yj=c(2,nres+j)-yi
12836             zj=c(3,nres+j)-zi
12837             dxj=dc_norm(1,nres+j)
12838             dyj=dc_norm(2,nres+j)
12839             dzj=dc_norm(3,nres+j)
12840             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12841             rij=dsqrt(rrij)
12842             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12843
12844             if (sss.gt.0.0d0) then
12845
12846 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12847               call sc_angular
12848 ! Calculate whole angle-dependent part of epsilon and contributions
12849 ! to its derivatives
12850               fac=(rrij*sigsq)**expon2
12851               e1=fac*fac*aa_aq(itypi,itypj)
12852               e2=fac*bb_aq(itypi,itypj)
12853               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12854               eps2der=evdwij*eps3rt
12855               eps3der=evdwij*eps2rt
12856               evdwij=evdwij*eps2rt*eps3rt
12857               evdw=evdw+evdwij*sss
12858               if (lprn) then
12859               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12860               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12861 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12862 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12863 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12864 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12865 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12866 !d     &          evdwij
12867               endif
12868 ! Calculate gradient components.
12869               e1=e1*eps1*eps2rt**2*eps3rt**2
12870               fac=-expon*(e1+evdwij)
12871               sigder=fac/sigsq
12872               fac=rrij*fac
12873 ! Calculate radial part of the gradient
12874               gg(1)=xj*fac
12875               gg(2)=yj*fac
12876               gg(3)=zj*fac
12877 ! Calculate the angular part of the gradient and sum add the contributions
12878 ! to the appropriate components of the Cartesian gradient.
12879               call sc_grad_scale(sss)
12880             endif
12881           enddo      ! j
12882         enddo        ! iint
12883       enddo          ! i
12884 !     stop
12885       return
12886       end subroutine ebp_short
12887 !-----------------------------------------------------------------------------
12888       subroutine egb_long(evdw)
12889 !
12890 ! This subroutine calculates the interaction energy of nonbonded side chains
12891 ! assuming the Gay-Berne potential of interaction.
12892 !
12893       use calc_data
12894 !      implicit real*8 (a-h,o-z)
12895 !      include 'DIMENSIONS'
12896 !      include 'COMMON.GEO'
12897 !      include 'COMMON.VAR'
12898 !      include 'COMMON.LOCAL'
12899 !      include 'COMMON.CHAIN'
12900 !      include 'COMMON.DERIV'
12901 !      include 'COMMON.NAMES'
12902 !      include 'COMMON.INTERACT'
12903 !      include 'COMMON.IOUNITS'
12904 !      include 'COMMON.CALC'
12905 !      include 'COMMON.CONTROL'
12906       logical :: lprn
12907 !el local variables
12908       integer :: iint,itypi,itypi1,itypj,subchap
12909       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
12910       real(kind=8) :: sss,e1,e2,evdw,sss_grad
12911       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
12912                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
12913                     ssgradlipi,ssgradlipj
12914
12915
12916       evdw=0.0D0
12917 !cccc      energy_dec=.false.
12918 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
12919       evdw=0.0D0
12920       lprn=.false.
12921 !     if (icall.eq.0) lprn=.false.
12922 !el      ind=0
12923       do i=iatsc_s,iatsc_e
12924         itypi=itype(i,1)
12925         if (itypi.eq.ntyp1) cycle
12926         itypi1=itype(i+1,1)
12927         xi=c(1,nres+i)
12928         yi=c(2,nres+i)
12929         zi=c(3,nres+i)
12930           xi=mod(xi,boxxsize)
12931           if (xi.lt.0) xi=xi+boxxsize
12932           yi=mod(yi,boxysize)
12933           if (yi.lt.0) yi=yi+boxysize
12934           zi=mod(zi,boxzsize)
12935           if (zi.lt.0) zi=zi+boxzsize
12936        if ((zi.gt.bordlipbot)    &
12937         .and.(zi.lt.bordliptop)) then
12938 !C the energy transfer exist
12939         if (zi.lt.buflipbot) then
12940 !C what fraction I am in
12941          fracinbuf=1.0d0-    &
12942              ((zi-bordlipbot)/lipbufthick)
12943 !C lipbufthick is thickenes of lipid buffore
12944          sslipi=sscalelip(fracinbuf)
12945          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
12946         elseif (zi.gt.bufliptop) then
12947          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
12948          sslipi=sscalelip(fracinbuf)
12949          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
12950         else
12951          sslipi=1.0d0
12952          ssgradlipi=0.0
12953         endif
12954        else
12955          sslipi=0.0d0
12956          ssgradlipi=0.0
12957        endif
12958
12959         dxi=dc_norm(1,nres+i)
12960         dyi=dc_norm(2,nres+i)
12961         dzi=dc_norm(3,nres+i)
12962 !        dsci_inv=dsc_inv(itypi)
12963         dsci_inv=vbld_inv(i+nres)
12964 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
12965 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
12966 !
12967 ! Calculate SC interaction energy.
12968 !
12969         do iint=1,nint_gr(i)
12970           do j=istart(i,iint),iend(i,iint)
12971             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
12972 !              call dyn_ssbond_ene(i,j,evdwij)
12973 !              evdw=evdw+evdwij
12974 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12975 !                              'evdw',i,j,evdwij,' ss'
12976 !              if (energy_dec) write (iout,*) &
12977 !                              'evdw',i,j,evdwij,' ss'
12978 !             do k=j+1,iend(i,iint)
12979 !C search over all next residues
12980 !              if (dyn_ss_mask(k)) then
12981 !C check if they are cysteins
12982 !C              write(iout,*) 'k=',k
12983
12984 !c              write(iout,*) "PRZED TRI", evdwij
12985 !               evdwij_przed_tri=evdwij
12986 !              call triple_ssbond_ene(i,j,k,evdwij)
12987 !c               if(evdwij_przed_tri.ne.evdwij) then
12988 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
12989 !c               endif
12990
12991 !c              write(iout,*) "PO TRI", evdwij
12992 !C call the energy function that removes the artifical triple disulfide
12993 !C bond the soubroutine is located in ssMD.F
12994 !              evdw=evdw+evdwij
12995               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
12996                             'evdw',i,j,evdwij,'tss'
12997 !              endif!dyn_ss_mask(k)
12998 !             enddo! k
12999
13000             ELSE
13001 !el            ind=ind+1
13002             itypj=itype(j,1)
13003             if (itypj.eq.ntyp1) cycle
13004 !            dscj_inv=dsc_inv(itypj)
13005             dscj_inv=vbld_inv(j+nres)
13006 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13007 !     &       1.0d0/vbld(j+nres)
13008 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13009             sig0ij=sigma(itypi,itypj)
13010             chi1=chi(itypi,itypj)
13011             chi2=chi(itypj,itypi)
13012             chi12=chi1*chi2
13013             chip1=chip(itypi)
13014             chip2=chip(itypj)
13015             chip12=chip1*chip2
13016             alf1=alp(itypi)
13017             alf2=alp(itypj)
13018             alf12=0.5D0*(alf1+alf2)
13019             xj=c(1,nres+j)
13020             yj=c(2,nres+j)
13021             zj=c(3,nres+j)
13022 ! Searching for nearest neighbour
13023           xj=mod(xj,boxxsize)
13024           if (xj.lt.0) xj=xj+boxxsize
13025           yj=mod(yj,boxysize)
13026           if (yj.lt.0) yj=yj+boxysize
13027           zj=mod(zj,boxzsize)
13028           if (zj.lt.0) zj=zj+boxzsize
13029        if ((zj.gt.bordlipbot)   &
13030       .and.(zj.lt.bordliptop)) then
13031 !C the energy transfer exist
13032         if (zj.lt.buflipbot) then
13033 !C what fraction I am in
13034          fracinbuf=1.0d0-  &
13035              ((zj-bordlipbot)/lipbufthick)
13036 !C lipbufthick is thickenes of lipid buffore
13037          sslipj=sscalelip(fracinbuf)
13038          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13039         elseif (zj.gt.bufliptop) then
13040          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13041          sslipj=sscalelip(fracinbuf)
13042          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13043         else
13044          sslipj=1.0d0
13045          ssgradlipj=0.0
13046         endif
13047        else
13048          sslipj=0.0d0
13049          ssgradlipj=0.0
13050        endif
13051       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13052        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13053       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13054        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13055
13056           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13057           xj_safe=xj
13058           yj_safe=yj
13059           zj_safe=zj
13060           subchap=0
13061           do xshift=-1,1
13062           do yshift=-1,1
13063           do zshift=-1,1
13064           xj=xj_safe+xshift*boxxsize
13065           yj=yj_safe+yshift*boxysize
13066           zj=zj_safe+zshift*boxzsize
13067           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13068           if(dist_temp.lt.dist_init) then
13069             dist_init=dist_temp
13070             xj_temp=xj
13071             yj_temp=yj
13072             zj_temp=zj
13073             subchap=1
13074           endif
13075           enddo
13076           enddo
13077           enddo
13078           if (subchap.eq.1) then
13079           xj=xj_temp-xi
13080           yj=yj_temp-yi
13081           zj=zj_temp-zi
13082           else
13083           xj=xj_safe-xi
13084           yj=yj_safe-yi
13085           zj=zj_safe-zi
13086           endif
13087
13088             dxj=dc_norm(1,nres+j)
13089             dyj=dc_norm(2,nres+j)
13090             dzj=dc_norm(3,nres+j)
13091             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13092             rij=dsqrt(rrij)
13093             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13094             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13095             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13096             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13097             if (sss_ele_cut.le.0.0) cycle
13098             if (sss.lt.1.0d0) then
13099
13100 ! Calculate angle-dependent terms of energy and contributions to their
13101 ! derivatives.
13102               call sc_angular
13103               sigsq=1.0D0/sigsq
13104               sig=sig0ij*dsqrt(sigsq)
13105               rij_shift=1.0D0/rij-sig+sig0ij
13106 ! for diagnostics; uncomment
13107 !              rij_shift=1.2*sig0ij
13108 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13109               if (rij_shift.le.0.0D0) then
13110                 evdw=1.0D20
13111 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13112 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13113 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13114                 return
13115               endif
13116               sigder=-sig*sigsq
13117 !---------------------------------------------------------------
13118               rij_shift=1.0D0/rij_shift
13119               fac=rij_shift**expon
13120               e1=fac*fac*aa
13121               e2=fac*bb
13122               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13123               eps2der=evdwij*eps3rt
13124               eps3der=evdwij*eps2rt
13125 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13126 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13127               evdwij=evdwij*eps2rt*eps3rt
13128               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13129               if (lprn) then
13130               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13131               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13132               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13133                 restyp(itypi,1),i,restyp(itypj,1),j,&
13134                 epsi,sigm,chi1,chi2,chip1,chip2,&
13135                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13136                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13137                 evdwij
13138               endif
13139
13140               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13141                               'evdw',i,j,evdwij
13142 !              if (energy_dec) write (iout,*) &
13143 !                              'evdw',i,j,evdwij,"egb_long"
13144
13145 ! Calculate gradient components.
13146               e1=e1*eps1*eps2rt**2*eps3rt**2
13147               fac=-expon*(e1+evdwij)*rij_shift
13148               sigder=fac*sigder
13149               fac=rij*fac
13150               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13151             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13152             /sigmaii(itypi,itypj))
13153 !              fac=0.0d0
13154 ! Calculate the radial part of the gradient
13155               gg(1)=xj*fac
13156               gg(2)=yj*fac
13157               gg(3)=zj*fac
13158 ! Calculate angular part of the gradient.
13159               call sc_grad_scale(1.0d0-sss)
13160             ENDIF    !mask_dyn_ss
13161             endif
13162           enddo      ! j
13163         enddo        ! iint
13164       enddo          ! i
13165 !      write (iout,*) "Number of loop steps in EGB:",ind
13166 !ccc      energy_dec=.false.
13167       return
13168       end subroutine egb_long
13169 !-----------------------------------------------------------------------------
13170       subroutine egb_short(evdw)
13171 !
13172 ! This subroutine calculates the interaction energy of nonbonded side chains
13173 ! assuming the Gay-Berne potential of interaction.
13174 !
13175       use calc_data
13176 !      implicit real*8 (a-h,o-z)
13177 !      include 'DIMENSIONS'
13178 !      include 'COMMON.GEO'
13179 !      include 'COMMON.VAR'
13180 !      include 'COMMON.LOCAL'
13181 !      include 'COMMON.CHAIN'
13182 !      include 'COMMON.DERIV'
13183 !      include 'COMMON.NAMES'
13184 !      include 'COMMON.INTERACT'
13185 !      include 'COMMON.IOUNITS'
13186 !      include 'COMMON.CALC'
13187 !      include 'COMMON.CONTROL'
13188       logical :: lprn
13189 !el local variables
13190       integer :: iint,itypi,itypi1,itypj,subchap
13191       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13192       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13193       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13194                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13195                     ssgradlipi,ssgradlipj
13196       evdw=0.0D0
13197 !cccc      energy_dec=.false.
13198 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13199       evdw=0.0D0
13200       lprn=.false.
13201 !     if (icall.eq.0) lprn=.false.
13202 !el      ind=0
13203       do i=iatsc_s,iatsc_e
13204         itypi=itype(i,1)
13205         if (itypi.eq.ntyp1) cycle
13206         itypi1=itype(i+1,1)
13207         xi=c(1,nres+i)
13208         yi=c(2,nres+i)
13209         zi=c(3,nres+i)
13210           xi=mod(xi,boxxsize)
13211           if (xi.lt.0) xi=xi+boxxsize
13212           yi=mod(yi,boxysize)
13213           if (yi.lt.0) yi=yi+boxysize
13214           zi=mod(zi,boxzsize)
13215           if (zi.lt.0) zi=zi+boxzsize
13216        if ((zi.gt.bordlipbot)    &
13217         .and.(zi.lt.bordliptop)) then
13218 !C the energy transfer exist
13219         if (zi.lt.buflipbot) then
13220 !C what fraction I am in
13221          fracinbuf=1.0d0-    &
13222              ((zi-bordlipbot)/lipbufthick)
13223 !C lipbufthick is thickenes of lipid buffore
13224          sslipi=sscalelip(fracinbuf)
13225          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13226         elseif (zi.gt.bufliptop) then
13227          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13228          sslipi=sscalelip(fracinbuf)
13229          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13230         else
13231          sslipi=1.0d0
13232          ssgradlipi=0.0
13233         endif
13234        else
13235          sslipi=0.0d0
13236          ssgradlipi=0.0
13237        endif
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
13245         dxi=dc_norm(1,nres+i)
13246         dyi=dc_norm(2,nres+i)
13247         dzi=dc_norm(3,nres+i)
13248 !        dsci_inv=dsc_inv(itypi)
13249         dsci_inv=vbld_inv(i+nres)
13250 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13251 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13252 !
13253 ! Calculate SC interaction energy.
13254 !
13255         do iint=1,nint_gr(i)
13256           do j=istart(i,iint),iend(i,iint)
13257             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13258               call dyn_ssbond_ene(i,j,evdwij)
13259               evdw=evdw+evdwij
13260               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13261                               'evdw',i,j,evdwij,' ss'
13262              do k=j+1,iend(i,iint)
13263 !C search over all next residues
13264               if (dyn_ss_mask(k)) then
13265 !C check if they are cysteins
13266 !C              write(iout,*) 'k=',k
13267
13268 !c              write(iout,*) "PRZED TRI", evdwij
13269 !               evdwij_przed_tri=evdwij
13270               call triple_ssbond_ene(i,j,k,evdwij)
13271 !c               if(evdwij_przed_tri.ne.evdwij) then
13272 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13273 !c               endif
13274
13275 !c              write(iout,*) "PO TRI", evdwij
13276 !C call the energy function that removes the artifical triple disulfide
13277 !C bond the soubroutine is located in ssMD.F
13278               evdw=evdw+evdwij
13279               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13280                             'evdw',i,j,evdwij,'tss'
13281               endif!dyn_ss_mask(k)
13282              enddo! k
13283
13284 !              if (energy_dec) write (iout,*) &
13285 !                              'evdw',i,j,evdwij,' ss'
13286             ELSE
13287 !el            ind=ind+1
13288             itypj=itype(j,1)
13289             if (itypj.eq.ntyp1) cycle
13290 !            dscj_inv=dsc_inv(itypj)
13291             dscj_inv=vbld_inv(j+nres)
13292 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13293 !     &       1.0d0/vbld(j+nres)
13294 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13295             sig0ij=sigma(itypi,itypj)
13296             chi1=chi(itypi,itypj)
13297             chi2=chi(itypj,itypi)
13298             chi12=chi1*chi2
13299             chip1=chip(itypi)
13300             chip2=chip(itypj)
13301             chip12=chip1*chip2
13302             alf1=alp(itypi)
13303             alf2=alp(itypj)
13304             alf12=0.5D0*(alf1+alf2)
13305 !            xj=c(1,nres+j)-xi
13306 !            yj=c(2,nres+j)-yi
13307 !            zj=c(3,nres+j)-zi
13308             xj=c(1,nres+j)
13309             yj=c(2,nres+j)
13310             zj=c(3,nres+j)
13311 ! Searching for nearest neighbour
13312           xj=mod(xj,boxxsize)
13313           if (xj.lt.0) xj=xj+boxxsize
13314           yj=mod(yj,boxysize)
13315           if (yj.lt.0) yj=yj+boxysize
13316           zj=mod(zj,boxzsize)
13317           if (zj.lt.0) zj=zj+boxzsize
13318        if ((zj.gt.bordlipbot)   &
13319       .and.(zj.lt.bordliptop)) then
13320 !C the energy transfer exist
13321         if (zj.lt.buflipbot) then
13322 !C what fraction I am in
13323          fracinbuf=1.0d0-  &
13324              ((zj-bordlipbot)/lipbufthick)
13325 !C lipbufthick is thickenes of lipid buffore
13326          sslipj=sscalelip(fracinbuf)
13327          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13328         elseif (zj.gt.bufliptop) then
13329          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13330          sslipj=sscalelip(fracinbuf)
13331          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13332         else
13333          sslipj=1.0d0
13334          ssgradlipj=0.0
13335         endif
13336        else
13337          sslipj=0.0d0
13338          ssgradlipj=0.0
13339        endif
13340       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13341        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13342       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13343        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13344
13345           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13346           xj_safe=xj
13347           yj_safe=yj
13348           zj_safe=zj
13349           subchap=0
13350
13351           do xshift=-1,1
13352           do yshift=-1,1
13353           do zshift=-1,1
13354           xj=xj_safe+xshift*boxxsize
13355           yj=yj_safe+yshift*boxysize
13356           zj=zj_safe+zshift*boxzsize
13357           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13358           if(dist_temp.lt.dist_init) then
13359             dist_init=dist_temp
13360             xj_temp=xj
13361             yj_temp=yj
13362             zj_temp=zj
13363             subchap=1
13364           endif
13365           enddo
13366           enddo
13367           enddo
13368           if (subchap.eq.1) then
13369           xj=xj_temp-xi
13370           yj=yj_temp-yi
13371           zj=zj_temp-zi
13372           else
13373           xj=xj_safe-xi
13374           yj=yj_safe-yi
13375           zj=zj_safe-zi
13376           endif
13377
13378             dxj=dc_norm(1,nres+j)
13379             dyj=dc_norm(2,nres+j)
13380             dzj=dc_norm(3,nres+j)
13381             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13382             rij=dsqrt(rrij)
13383             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13384             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13385             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13386             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13387             if (sss_ele_cut.le.0.0) cycle
13388
13389             if (sss.gt.0.0d0) then
13390
13391 ! Calculate angle-dependent terms of energy and contributions to their
13392 ! derivatives.
13393               call sc_angular
13394               sigsq=1.0D0/sigsq
13395               sig=sig0ij*dsqrt(sigsq)
13396               rij_shift=1.0D0/rij-sig+sig0ij
13397 ! for diagnostics; uncomment
13398 !              rij_shift=1.2*sig0ij
13399 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13400               if (rij_shift.le.0.0D0) then
13401                 evdw=1.0D20
13402 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13403 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13404 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13405                 return
13406               endif
13407               sigder=-sig*sigsq
13408 !---------------------------------------------------------------
13409               rij_shift=1.0D0/rij_shift
13410               fac=rij_shift**expon
13411               e1=fac*fac*aa
13412               e2=fac*bb
13413               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13414               eps2der=evdwij*eps3rt
13415               eps3der=evdwij*eps2rt
13416 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13417 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13418               evdwij=evdwij*eps2rt*eps3rt
13419               evdw=evdw+evdwij*sss*sss_ele_cut
13420               if (lprn) then
13421               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13422               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13423               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13424                 restyp(itypi,1),i,restyp(itypj,1),j,&
13425                 epsi,sigm,chi1,chi2,chip1,chip2,&
13426                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13427                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13428                 evdwij
13429               endif
13430
13431               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13432                               'evdw',i,j,evdwij
13433 !              if (energy_dec) write (iout,*) &
13434 !                              'evdw',i,j,evdwij,"egb_short"
13435
13436 ! Calculate gradient components.
13437               e1=e1*eps1*eps2rt**2*eps3rt**2
13438               fac=-expon*(e1+evdwij)*rij_shift
13439               sigder=fac*sigder
13440               fac=rij*fac
13441               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13442             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13443             /sigmaii(itypi,itypj))
13444
13445 !              fac=0.0d0
13446 ! Calculate the radial part of the gradient
13447               gg(1)=xj*fac
13448               gg(2)=yj*fac
13449               gg(3)=zj*fac
13450 ! Calculate angular part of the gradient.
13451               call sc_grad_scale(sss)
13452             endif
13453           ENDIF !mask_dyn_ss
13454           enddo      ! j
13455         enddo        ! iint
13456       enddo          ! i
13457 !      write (iout,*) "Number of loop steps in EGB:",ind
13458 !ccc      energy_dec=.false.
13459       return
13460       end subroutine egb_short
13461 !-----------------------------------------------------------------------------
13462       subroutine egbv_long(evdw)
13463 !
13464 ! This subroutine calculates the interaction energy of nonbonded side chains
13465 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13466 !
13467       use calc_data
13468 !      implicit real*8 (a-h,o-z)
13469 !      include 'DIMENSIONS'
13470 !      include 'COMMON.GEO'
13471 !      include 'COMMON.VAR'
13472 !      include 'COMMON.LOCAL'
13473 !      include 'COMMON.CHAIN'
13474 !      include 'COMMON.DERIV'
13475 !      include 'COMMON.NAMES'
13476 !      include 'COMMON.INTERACT'
13477 !      include 'COMMON.IOUNITS'
13478 !      include 'COMMON.CALC'
13479       use comm_srutu
13480 !el      integer :: icall
13481 !el      common /srutu/ icall
13482       logical :: lprn
13483 !el local variables
13484       integer :: iint,itypi,itypi1,itypj
13485       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13486       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13487       evdw=0.0D0
13488 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13489       evdw=0.0D0
13490       lprn=.false.
13491 !     if (icall.eq.0) lprn=.true.
13492 !el      ind=0
13493       do i=iatsc_s,iatsc_e
13494         itypi=itype(i,1)
13495         if (itypi.eq.ntyp1) cycle
13496         itypi1=itype(i+1,1)
13497         xi=c(1,nres+i)
13498         yi=c(2,nres+i)
13499         zi=c(3,nres+i)
13500         dxi=dc_norm(1,nres+i)
13501         dyi=dc_norm(2,nres+i)
13502         dzi=dc_norm(3,nres+i)
13503 !        dsci_inv=dsc_inv(itypi)
13504         dsci_inv=vbld_inv(i+nres)
13505 !
13506 ! Calculate SC interaction energy.
13507 !
13508         do iint=1,nint_gr(i)
13509           do j=istart(i,iint),iend(i,iint)
13510 !el            ind=ind+1
13511             itypj=itype(j,1)
13512             if (itypj.eq.ntyp1) cycle
13513 !            dscj_inv=dsc_inv(itypj)
13514             dscj_inv=vbld_inv(j+nres)
13515             sig0ij=sigma(itypi,itypj)
13516             r0ij=r0(itypi,itypj)
13517             chi1=chi(itypi,itypj)
13518             chi2=chi(itypj,itypi)
13519             chi12=chi1*chi2
13520             chip1=chip(itypi)
13521             chip2=chip(itypj)
13522             chip12=chip1*chip2
13523             alf1=alp(itypi)
13524             alf2=alp(itypj)
13525             alf12=0.5D0*(alf1+alf2)
13526             xj=c(1,nres+j)-xi
13527             yj=c(2,nres+j)-yi
13528             zj=c(3,nres+j)-zi
13529             dxj=dc_norm(1,nres+j)
13530             dyj=dc_norm(2,nres+j)
13531             dzj=dc_norm(3,nres+j)
13532             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13533             rij=dsqrt(rrij)
13534
13535             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13536
13537             if (sss.lt.1.0d0) then
13538
13539 ! Calculate angle-dependent terms of energy and contributions to their
13540 ! derivatives.
13541               call sc_angular
13542               sigsq=1.0D0/sigsq
13543               sig=sig0ij*dsqrt(sigsq)
13544               rij_shift=1.0D0/rij-sig+r0ij
13545 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13546               if (rij_shift.le.0.0D0) then
13547                 evdw=1.0D20
13548                 return
13549               endif
13550               sigder=-sig*sigsq
13551 !---------------------------------------------------------------
13552               rij_shift=1.0D0/rij_shift
13553               fac=rij_shift**expon
13554               e1=fac*fac*aa_aq(itypi,itypj)
13555               e2=fac*bb_aq(itypi,itypj)
13556               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13557               eps2der=evdwij*eps3rt
13558               eps3der=evdwij*eps2rt
13559               fac_augm=rrij**expon
13560               e_augm=augm(itypi,itypj)*fac_augm
13561               evdwij=evdwij*eps2rt*eps3rt
13562               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13563               if (lprn) then
13564               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13565               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13566               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13567                 restyp(itypi,1),i,restyp(itypj,1),j,&
13568                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13569                 chi1,chi2,chip1,chip2,&
13570                 eps1,eps2rt**2,eps3rt**2,&
13571                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13572                 evdwij+e_augm
13573               endif
13574 ! Calculate gradient components.
13575               e1=e1*eps1*eps2rt**2*eps3rt**2
13576               fac=-expon*(e1+evdwij)*rij_shift
13577               sigder=fac*sigder
13578               fac=rij*fac-2*expon*rrij*e_augm
13579 ! Calculate the radial part of the gradient
13580               gg(1)=xj*fac
13581               gg(2)=yj*fac
13582               gg(3)=zj*fac
13583 ! Calculate angular part of the gradient.
13584               call sc_grad_scale(1.0d0-sss)
13585             endif
13586           enddo      ! j
13587         enddo        ! iint
13588       enddo          ! i
13589       end subroutine egbv_long
13590 !-----------------------------------------------------------------------------
13591       subroutine egbv_short(evdw)
13592 !
13593 ! This subroutine calculates the interaction energy of nonbonded side chains
13594 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13595 !
13596       use calc_data
13597 !      implicit real*8 (a-h,o-z)
13598 !      include 'DIMENSIONS'
13599 !      include 'COMMON.GEO'
13600 !      include 'COMMON.VAR'
13601 !      include 'COMMON.LOCAL'
13602 !      include 'COMMON.CHAIN'
13603 !      include 'COMMON.DERIV'
13604 !      include 'COMMON.NAMES'
13605 !      include 'COMMON.INTERACT'
13606 !      include 'COMMON.IOUNITS'
13607 !      include 'COMMON.CALC'
13608       use comm_srutu
13609 !el      integer :: icall
13610 !el      common /srutu/ icall
13611       logical :: lprn
13612 !el local variables
13613       integer :: iint,itypi,itypi1,itypj
13614       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13615       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13616       evdw=0.0D0
13617 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13618       evdw=0.0D0
13619       lprn=.false.
13620 !     if (icall.eq.0) lprn=.true.
13621 !el      ind=0
13622       do i=iatsc_s,iatsc_e
13623         itypi=itype(i,1)
13624         if (itypi.eq.ntyp1) cycle
13625         itypi1=itype(i+1,1)
13626         xi=c(1,nres+i)
13627         yi=c(2,nres+i)
13628         zi=c(3,nres+i)
13629         dxi=dc_norm(1,nres+i)
13630         dyi=dc_norm(2,nres+i)
13631         dzi=dc_norm(3,nres+i)
13632 !        dsci_inv=dsc_inv(itypi)
13633         dsci_inv=vbld_inv(i+nres)
13634 !
13635 ! Calculate SC interaction energy.
13636 !
13637         do iint=1,nint_gr(i)
13638           do j=istart(i,iint),iend(i,iint)
13639 !el            ind=ind+1
13640             itypj=itype(j,1)
13641             if (itypj.eq.ntyp1) cycle
13642 !            dscj_inv=dsc_inv(itypj)
13643             dscj_inv=vbld_inv(j+nres)
13644             sig0ij=sigma(itypi,itypj)
13645             r0ij=r0(itypi,itypj)
13646             chi1=chi(itypi,itypj)
13647             chi2=chi(itypj,itypi)
13648             chi12=chi1*chi2
13649             chip1=chip(itypi)
13650             chip2=chip(itypj)
13651             chip12=chip1*chip2
13652             alf1=alp(itypi)
13653             alf2=alp(itypj)
13654             alf12=0.5D0*(alf1+alf2)
13655             xj=c(1,nres+j)-xi
13656             yj=c(2,nres+j)-yi
13657             zj=c(3,nres+j)-zi
13658             dxj=dc_norm(1,nres+j)
13659             dyj=dc_norm(2,nres+j)
13660             dzj=dc_norm(3,nres+j)
13661             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13662             rij=dsqrt(rrij)
13663
13664             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13665
13666             if (sss.gt.0.0d0) then
13667
13668 ! Calculate angle-dependent terms of energy and contributions to their
13669 ! derivatives.
13670               call sc_angular
13671               sigsq=1.0D0/sigsq
13672               sig=sig0ij*dsqrt(sigsq)
13673               rij_shift=1.0D0/rij-sig+r0ij
13674 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13675               if (rij_shift.le.0.0D0) then
13676                 evdw=1.0D20
13677                 return
13678               endif
13679               sigder=-sig*sigsq
13680 !---------------------------------------------------------------
13681               rij_shift=1.0D0/rij_shift
13682               fac=rij_shift**expon
13683               e1=fac*fac*aa_aq(itypi,itypj)
13684               e2=fac*bb_aq(itypi,itypj)
13685               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13686               eps2der=evdwij*eps3rt
13687               eps3der=evdwij*eps2rt
13688               fac_augm=rrij**expon
13689               e_augm=augm(itypi,itypj)*fac_augm
13690               evdwij=evdwij*eps2rt*eps3rt
13691               evdw=evdw+(evdwij+e_augm)*sss
13692               if (lprn) then
13693               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13694               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13695               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13696                 restyp(itypi,1),i,restyp(itypj,1),j,&
13697                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13698                 chi1,chi2,chip1,chip2,&
13699                 eps1,eps2rt**2,eps3rt**2,&
13700                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13701                 evdwij+e_augm
13702               endif
13703 ! Calculate gradient components.
13704               e1=e1*eps1*eps2rt**2*eps3rt**2
13705               fac=-expon*(e1+evdwij)*rij_shift
13706               sigder=fac*sigder
13707               fac=rij*fac-2*expon*rrij*e_augm
13708 ! Calculate the radial part of the gradient
13709               gg(1)=xj*fac
13710               gg(2)=yj*fac
13711               gg(3)=zj*fac
13712 ! Calculate angular part of the gradient.
13713               call sc_grad_scale(sss)
13714             endif
13715           enddo      ! j
13716         enddo        ! iint
13717       enddo          ! i
13718       end subroutine egbv_short
13719 !-----------------------------------------------------------------------------
13720       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13721 !
13722 ! This subroutine calculates the average interaction energy and its gradient
13723 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13724 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13725 ! The potential depends both on the distance of peptide-group centers and on
13726 ! the orientation of the CA-CA virtual bonds.
13727 !
13728 !      implicit real*8 (a-h,o-z)
13729
13730       use comm_locel
13731 #ifdef MPI
13732       include 'mpif.h'
13733 #endif
13734 !      include 'DIMENSIONS'
13735 !      include 'COMMON.CONTROL'
13736 !      include 'COMMON.SETUP'
13737 !      include 'COMMON.IOUNITS'
13738 !      include 'COMMON.GEO'
13739 !      include 'COMMON.VAR'
13740 !      include 'COMMON.LOCAL'
13741 !      include 'COMMON.CHAIN'
13742 !      include 'COMMON.DERIV'
13743 !      include 'COMMON.INTERACT'
13744 !      include 'COMMON.CONTACTS'
13745 !      include 'COMMON.TORSION'
13746 !      include 'COMMON.VECTORS'
13747 !      include 'COMMON.FFIELD'
13748 !      include 'COMMON.TIME1'
13749       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13750       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13751       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13752 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13753       real(kind=8),dimension(4) :: muij
13754 !el      integer :: num_conti,j1,j2
13755 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13756 !el                   dz_normi,xmedi,ymedi,zmedi
13757 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13758 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13759 !el          num_conti,j1,j2
13760 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13761 #ifdef MOMENT
13762       real(kind=8) :: scal_el=1.0d0
13763 #else
13764       real(kind=8) :: scal_el=0.5d0
13765 #endif
13766 ! 12/13/98
13767 ! 13-go grudnia roku pamietnego...
13768       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13769                                              0.0d0,1.0d0,0.0d0,&
13770                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13771 !el local variables
13772       integer :: i,j,k
13773       real(kind=8) :: fac
13774       real(kind=8) :: dxj,dyj,dzj
13775       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13776
13777 !      allocate(num_cont_hb(nres)) !(maxres)
13778 !d      write(iout,*) 'In EELEC'
13779 !d      do i=1,nloctyp
13780 !d        write(iout,*) 'Type',i
13781 !d        write(iout,*) 'B1',B1(:,i)
13782 !d        write(iout,*) 'B2',B2(:,i)
13783 !d        write(iout,*) 'CC',CC(:,:,i)
13784 !d        write(iout,*) 'DD',DD(:,:,i)
13785 !d        write(iout,*) 'EE',EE(:,:,i)
13786 !d      enddo
13787 !d      call check_vecgrad
13788 !d      stop
13789       if (icheckgrad.eq.1) then
13790         do i=1,nres-1
13791           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13792           do k=1,3
13793             dc_norm(k,i)=dc(k,i)*fac
13794           enddo
13795 !          write (iout,*) 'i',i,' fac',fac
13796         enddo
13797       endif
13798       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13799           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13800           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13801 !        call vec_and_deriv
13802 #ifdef TIMING
13803         time01=MPI_Wtime()
13804 #endif
13805 !        print *, "before set matrices"
13806         call set_matrices
13807 !        print *,"after set martices"
13808 #ifdef TIMING
13809         time_mat=time_mat+MPI_Wtime()-time01
13810 #endif
13811       endif
13812 !d      do i=1,nres-1
13813 !d        write (iout,*) 'i=',i
13814 !d        do k=1,3
13815 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
13816 !d        enddo
13817 !d        do k=1,3
13818 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
13819 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
13820 !d        enddo
13821 !d      enddo
13822       t_eelecij=0.0d0
13823       ees=0.0D0
13824       evdw1=0.0D0
13825       eel_loc=0.0d0
13826       eello_turn3=0.0d0
13827       eello_turn4=0.0d0
13828 !el      ind=0
13829       do i=1,nres
13830         num_cont_hb(i)=0
13831       enddo
13832 !d      print '(a)','Enter EELEC'
13833 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
13834 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
13835 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
13836       do i=1,nres
13837         gel_loc_loc(i)=0.0d0
13838         gcorr_loc(i)=0.0d0
13839       enddo
13840 !
13841 !
13842 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
13843 !
13844 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
13845 !
13846       do i=iturn3_start,iturn3_end
13847         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
13848         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
13849         dxi=dc(1,i)
13850         dyi=dc(2,i)
13851         dzi=dc(3,i)
13852         dx_normi=dc_norm(1,i)
13853         dy_normi=dc_norm(2,i)
13854         dz_normi=dc_norm(3,i)
13855         xmedi=c(1,i)+0.5d0*dxi
13856         ymedi=c(2,i)+0.5d0*dyi
13857         zmedi=c(3,i)+0.5d0*dzi
13858           xmedi=dmod(xmedi,boxxsize)
13859           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13860           ymedi=dmod(ymedi,boxysize)
13861           if (ymedi.lt.0) ymedi=ymedi+boxysize
13862           zmedi=dmod(zmedi,boxzsize)
13863           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13864         num_conti=0
13865         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
13866         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
13867         num_cont_hb(i)=num_conti
13868       enddo
13869       do i=iturn4_start,iturn4_end
13870         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
13871           .or. itype(i+3,1).eq.ntyp1 &
13872           .or. itype(i+4,1).eq.ntyp1) cycle
13873         dxi=dc(1,i)
13874         dyi=dc(2,i)
13875         dzi=dc(3,i)
13876         dx_normi=dc_norm(1,i)
13877         dy_normi=dc_norm(2,i)
13878         dz_normi=dc_norm(3,i)
13879         xmedi=c(1,i)+0.5d0*dxi
13880         ymedi=c(2,i)+0.5d0*dyi
13881         zmedi=c(3,i)+0.5d0*dzi
13882           xmedi=dmod(xmedi,boxxsize)
13883           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13884           ymedi=dmod(ymedi,boxysize)
13885           if (ymedi.lt.0) ymedi=ymedi+boxysize
13886           zmedi=dmod(zmedi,boxzsize)
13887           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13888         num_conti=num_cont_hb(i)
13889         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
13890         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
13891           call eturn4(i,eello_turn4)
13892         num_cont_hb(i)=num_conti
13893       enddo   ! i
13894 !
13895 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
13896 !
13897       do i=iatel_s,iatel_e
13898         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
13899         dxi=dc(1,i)
13900         dyi=dc(2,i)
13901         dzi=dc(3,i)
13902         dx_normi=dc_norm(1,i)
13903         dy_normi=dc_norm(2,i)
13904         dz_normi=dc_norm(3,i)
13905         xmedi=c(1,i)+0.5d0*dxi
13906         ymedi=c(2,i)+0.5d0*dyi
13907         zmedi=c(3,i)+0.5d0*dzi
13908           xmedi=dmod(xmedi,boxxsize)
13909           if (xmedi.lt.0) xmedi=xmedi+boxxsize
13910           ymedi=dmod(ymedi,boxysize)
13911           if (ymedi.lt.0) ymedi=ymedi+boxysize
13912           zmedi=dmod(zmedi,boxzsize)
13913           if (zmedi.lt.0) zmedi=zmedi+boxzsize
13914 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
13915         num_conti=num_cont_hb(i)
13916         do j=ielstart(i),ielend(i)
13917           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
13918           call eelecij_scale(i,j,ees,evdw1,eel_loc)
13919         enddo ! j
13920         num_cont_hb(i)=num_conti
13921       enddo   ! i
13922 !      write (iout,*) "Number of loop steps in EELEC:",ind
13923 !d      do i=1,nres
13924 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
13925 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
13926 !d      enddo
13927 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
13928 !cc      eel_loc=eel_loc+eello_turn3
13929 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
13930       return
13931       end subroutine eelec_scale
13932 !-----------------------------------------------------------------------------
13933       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
13934 !      implicit real*8 (a-h,o-z)
13935
13936       use comm_locel
13937 !      include 'DIMENSIONS'
13938 #ifdef MPI
13939       include "mpif.h"
13940 #endif
13941 !      include 'COMMON.CONTROL'
13942 !      include 'COMMON.IOUNITS'
13943 !      include 'COMMON.GEO'
13944 !      include 'COMMON.VAR'
13945 !      include 'COMMON.LOCAL'
13946 !      include 'COMMON.CHAIN'
13947 !      include 'COMMON.DERIV'
13948 !      include 'COMMON.INTERACT'
13949 !      include 'COMMON.CONTACTS'
13950 !      include 'COMMON.TORSION'
13951 !      include 'COMMON.VECTORS'
13952 !      include 'COMMON.FFIELD'
13953 !      include 'COMMON.TIME1'
13954       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
13955       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
13956       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13957 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13958       real(kind=8),dimension(4) :: muij
13959       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13960                     dist_temp, dist_init,sss_grad
13961       integer xshift,yshift,zshift
13962
13963 !el      integer :: num_conti,j1,j2
13964 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13965 !el                   dz_normi,xmedi,ymedi,zmedi
13966 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13967 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13968 !el          num_conti,j1,j2
13969 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13970 #ifdef MOMENT
13971       real(kind=8) :: scal_el=1.0d0
13972 #else
13973       real(kind=8) :: scal_el=0.5d0
13974 #endif
13975 ! 12/13/98
13976 ! 13-go grudnia roku pamietnego...
13977       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13978                                              0.0d0,1.0d0,0.0d0,&
13979                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13980 !el local variables
13981       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
13982       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
13983       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
13984       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
13985       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
13986       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
13987       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
13988                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
13989                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
13990                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
13991                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
13992                   ecosam,ecosbm,ecosgm,ghalf,time00
13993 !      integer :: maxconts
13994 !      maxconts = nres/4
13995 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13996 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13997 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13998 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
13999 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14000 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14001 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14002 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14003 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14004 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14005 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14006 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14007 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14008
14009 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14010 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14011
14012 #ifdef MPI
14013           time00=MPI_Wtime()
14014 #endif
14015 !d      write (iout,*) "eelecij",i,j
14016 !el          ind=ind+1
14017           iteli=itel(i)
14018           itelj=itel(j)
14019           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14020           aaa=app(iteli,itelj)
14021           bbb=bpp(iteli,itelj)
14022           ael6i=ael6(iteli,itelj)
14023           ael3i=ael3(iteli,itelj)
14024           dxj=dc(1,j)
14025           dyj=dc(2,j)
14026           dzj=dc(3,j)
14027           dx_normj=dc_norm(1,j)
14028           dy_normj=dc_norm(2,j)
14029           dz_normj=dc_norm(3,j)
14030 !          xj=c(1,j)+0.5D0*dxj-xmedi
14031 !          yj=c(2,j)+0.5D0*dyj-ymedi
14032 !          zj=c(3,j)+0.5D0*dzj-zmedi
14033           xj=c(1,j)+0.5D0*dxj
14034           yj=c(2,j)+0.5D0*dyj
14035           zj=c(3,j)+0.5D0*dzj
14036           xj=mod(xj,boxxsize)
14037           if (xj.lt.0) xj=xj+boxxsize
14038           yj=mod(yj,boxysize)
14039           if (yj.lt.0) yj=yj+boxysize
14040           zj=mod(zj,boxzsize)
14041           if (zj.lt.0) zj=zj+boxzsize
14042       isubchap=0
14043       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14044       xj_safe=xj
14045       yj_safe=yj
14046       zj_safe=zj
14047       do xshift=-1,1
14048       do yshift=-1,1
14049       do zshift=-1,1
14050           xj=xj_safe+xshift*boxxsize
14051           yj=yj_safe+yshift*boxysize
14052           zj=zj_safe+zshift*boxzsize
14053           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14054           if(dist_temp.lt.dist_init) then
14055             dist_init=dist_temp
14056             xj_temp=xj
14057             yj_temp=yj
14058             zj_temp=zj
14059             isubchap=1
14060           endif
14061        enddo
14062        enddo
14063        enddo
14064        if (isubchap.eq.1) then
14065 !C          print *,i,j
14066           xj=xj_temp-xmedi
14067           yj=yj_temp-ymedi
14068           zj=zj_temp-zmedi
14069        else
14070           xj=xj_safe-xmedi
14071           yj=yj_safe-ymedi
14072           zj=zj_safe-zmedi
14073        endif
14074
14075           rij=xj*xj+yj*yj+zj*zj
14076           rrmij=1.0D0/rij
14077           rij=dsqrt(rij)
14078           rmij=1.0D0/rij
14079 ! For extracting the short-range part of Evdwpp
14080           sss=sscale(rij/rpp(iteli,itelj))
14081             sss_ele_cut=sscale_ele(rij)
14082             sss_ele_grad=sscagrad_ele(rij)
14083             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14084 !             sss_ele_cut=1.0d0
14085 !             sss_ele_grad=0.0d0
14086             if (sss_ele_cut.le.0.0) go to 128
14087
14088           r3ij=rrmij*rmij
14089           r6ij=r3ij*r3ij
14090           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14091           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14092           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14093           fac=cosa-3.0D0*cosb*cosg
14094           ev1=aaa*r6ij*r6ij
14095 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14096           if (j.eq.i+2) ev1=scal_el*ev1
14097           ev2=bbb*r6ij
14098           fac3=ael6i*r6ij
14099           fac4=ael3i*r3ij
14100           evdwij=ev1+ev2
14101           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14102           el2=fac4*fac
14103           eesij=el1+el2
14104 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14105           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14106           ees=ees+eesij*sss_ele_cut
14107           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14108 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14109 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14110 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14111 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14112
14113           if (energy_dec) then
14114               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14115               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14116           endif
14117
14118 !
14119 ! Calculate contributions to the Cartesian gradient.
14120 !
14121 #ifdef SPLITELE
14122           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14123           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14124           fac1=fac
14125           erij(1)=xj*rmij
14126           erij(2)=yj*rmij
14127           erij(3)=zj*rmij
14128 !
14129 ! Radial derivatives. First process both termini of the fragment (i,j)
14130 !
14131           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14132           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14133           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14134 !          do k=1,3
14135 !            ghalf=0.5D0*ggg(k)
14136 !            gelc(k,i)=gelc(k,i)+ghalf
14137 !            gelc(k,j)=gelc(k,j)+ghalf
14138 !          enddo
14139 ! 9/28/08 AL Gradient compotents will be summed only at the end
14140           do k=1,3
14141             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14142             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14143           enddo
14144 !
14145 ! Loop over residues i+1 thru j-1.
14146 !
14147 !grad          do k=i+1,j-1
14148 !grad            do l=1,3
14149 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14150 !grad            enddo
14151 !grad          enddo
14152           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14153           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14154           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14155           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14156           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14157           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14158 !          do k=1,3
14159 !            ghalf=0.5D0*ggg(k)
14160 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14161 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14162 !          enddo
14163 ! 9/28/08 AL Gradient compotents will be summed only at the end
14164           do k=1,3
14165             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14166             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14167           enddo
14168 !
14169 ! Loop over residues i+1 thru j-1.
14170 !
14171 !grad          do k=i+1,j-1
14172 !grad            do l=1,3
14173 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14174 !grad            enddo
14175 !grad          enddo
14176 #else
14177           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14178           facel=(el1+eesij)*sss_ele_cut
14179           fac1=fac
14180           fac=-3*rrmij*(facvdw+facvdw+facel)
14181           erij(1)=xj*rmij
14182           erij(2)=yj*rmij
14183           erij(3)=zj*rmij
14184 !
14185 ! Radial derivatives. First process both termini of the fragment (i,j)
14186 !
14187           ggg(1)=fac*xj
14188           ggg(2)=fac*yj
14189           ggg(3)=fac*zj
14190 !          do k=1,3
14191 !            ghalf=0.5D0*ggg(k)
14192 !            gelc(k,i)=gelc(k,i)+ghalf
14193 !            gelc(k,j)=gelc(k,j)+ghalf
14194 !          enddo
14195 ! 9/28/08 AL Gradient compotents will be summed only at the end
14196           do k=1,3
14197             gelc_long(k,j)=gelc(k,j)+ggg(k)
14198             gelc_long(k,i)=gelc(k,i)-ggg(k)
14199           enddo
14200 !
14201 ! Loop over residues i+1 thru j-1.
14202 !
14203 !grad          do k=i+1,j-1
14204 !grad            do l=1,3
14205 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14206 !grad            enddo
14207 !grad          enddo
14208 ! 9/28/08 AL Gradient compotents will be summed only at the end
14209           ggg(1)=facvdw*xj
14210           ggg(2)=facvdw*yj
14211           ggg(3)=facvdw*zj
14212           do k=1,3
14213             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14214             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14215           enddo
14216 #endif
14217 !
14218 ! Angular part
14219 !
14220           ecosa=2.0D0*fac3*fac1+fac4
14221           fac4=-3.0D0*fac4
14222           fac3=-6.0D0*fac3
14223           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14224           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14225           do k=1,3
14226             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14227             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14228           enddo
14229 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14230 !d   &          (dcosg(k),k=1,3)
14231           do k=1,3
14232             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14233           enddo
14234 !          do k=1,3
14235 !            ghalf=0.5D0*ggg(k)
14236 !            gelc(k,i)=gelc(k,i)+ghalf
14237 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14238 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14239 !            gelc(k,j)=gelc(k,j)+ghalf
14240 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14241 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14242 !          enddo
14243 !grad          do k=i+1,j-1
14244 !grad            do l=1,3
14245 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14246 !grad            enddo
14247 !grad          enddo
14248           do k=1,3
14249             gelc(k,i)=gelc(k,i) &
14250                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14251                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14252                      *sss_ele_cut
14253             gelc(k,j)=gelc(k,j) &
14254                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14255                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14256                      *sss_ele_cut
14257             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14258             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14259           enddo
14260           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14261               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14262               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14263 !
14264 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14265 !   energy of a peptide unit is assumed in the form of a second-order
14266 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14267 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14268 !   are computed for EVERY pair of non-contiguous peptide groups.
14269 !
14270           if (j.lt.nres-1) then
14271             j1=j+1
14272             j2=j-1
14273           else
14274             j1=j-1
14275             j2=j-2
14276           endif
14277           kkk=0
14278           do k=1,2
14279             do l=1,2
14280               kkk=kkk+1
14281               muij(kkk)=mu(k,i)*mu(l,j)
14282             enddo
14283           enddo
14284 !d         write (iout,*) 'EELEC: i',i,' j',j
14285 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14286 !d          write(iout,*) 'muij',muij
14287           ury=scalar(uy(1,i),erij)
14288           urz=scalar(uz(1,i),erij)
14289           vry=scalar(uy(1,j),erij)
14290           vrz=scalar(uz(1,j),erij)
14291           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14292           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14293           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14294           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14295           fac=dsqrt(-ael6i)*r3ij
14296           a22=a22*fac
14297           a23=a23*fac
14298           a32=a32*fac
14299           a33=a33*fac
14300 !d          write (iout,'(4i5,4f10.5)')
14301 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14302 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14303 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14304 !d     &      uy(:,j),uz(:,j)
14305 !d          write (iout,'(4f10.5)')
14306 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14307 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14308 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14309 !d           write (iout,'(9f10.5/)')
14310 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14311 ! Derivatives of the elements of A in virtual-bond vectors
14312           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14313           do k=1,3
14314             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14315             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14316             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14317             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14318             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14319             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14320             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14321             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14322             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14323             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14324             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14325             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14326           enddo
14327 ! Compute radial contributions to the gradient
14328           facr=-3.0d0*rrmij
14329           a22der=a22*facr
14330           a23der=a23*facr
14331           a32der=a32*facr
14332           a33der=a33*facr
14333           agg(1,1)=a22der*xj
14334           agg(2,1)=a22der*yj
14335           agg(3,1)=a22der*zj
14336           agg(1,2)=a23der*xj
14337           agg(2,2)=a23der*yj
14338           agg(3,2)=a23der*zj
14339           agg(1,3)=a32der*xj
14340           agg(2,3)=a32der*yj
14341           agg(3,3)=a32der*zj
14342           agg(1,4)=a33der*xj
14343           agg(2,4)=a33der*yj
14344           agg(3,4)=a33der*zj
14345 ! Add the contributions coming from er
14346           fac3=-3.0d0*fac
14347           do k=1,3
14348             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14349             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14350             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14351             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14352           enddo
14353           do k=1,3
14354 ! Derivatives in DC(i)
14355 !grad            ghalf1=0.5d0*agg(k,1)
14356 !grad            ghalf2=0.5d0*agg(k,2)
14357 !grad            ghalf3=0.5d0*agg(k,3)
14358 !grad            ghalf4=0.5d0*agg(k,4)
14359             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14360             -3.0d0*uryg(k,2)*vry)!+ghalf1
14361             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14362             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14363             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14364             -3.0d0*urzg(k,2)*vry)!+ghalf3
14365             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14366             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14367 ! Derivatives in DC(i+1)
14368             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14369             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14370             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14371             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14372             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14373             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14374             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14375             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14376 ! Derivatives in DC(j)
14377             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14378             -3.0d0*vryg(k,2)*ury)!+ghalf1
14379             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14380             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14381             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14382             -3.0d0*vryg(k,2)*urz)!+ghalf3
14383             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14384             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14385 ! Derivatives in DC(j+1) or DC(nres-1)
14386             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14387             -3.0d0*vryg(k,3)*ury)
14388             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14389             -3.0d0*vrzg(k,3)*ury)
14390             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14391             -3.0d0*vryg(k,3)*urz)
14392             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14393             -3.0d0*vrzg(k,3)*urz)
14394 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14395 !grad              do l=1,4
14396 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14397 !grad              enddo
14398 !grad            endif
14399           enddo
14400           acipa(1,1)=a22
14401           acipa(1,2)=a23
14402           acipa(2,1)=a32
14403           acipa(2,2)=a33
14404           a22=-a22
14405           a23=-a23
14406           do l=1,2
14407             do k=1,3
14408               agg(k,l)=-agg(k,l)
14409               aggi(k,l)=-aggi(k,l)
14410               aggi1(k,l)=-aggi1(k,l)
14411               aggj(k,l)=-aggj(k,l)
14412               aggj1(k,l)=-aggj1(k,l)
14413             enddo
14414           enddo
14415           if (j.lt.nres-1) then
14416             a22=-a22
14417             a32=-a32
14418             do l=1,3,2
14419               do k=1,3
14420                 agg(k,l)=-agg(k,l)
14421                 aggi(k,l)=-aggi(k,l)
14422                 aggi1(k,l)=-aggi1(k,l)
14423                 aggj(k,l)=-aggj(k,l)
14424                 aggj1(k,l)=-aggj1(k,l)
14425               enddo
14426             enddo
14427           else
14428             a22=-a22
14429             a23=-a23
14430             a32=-a32
14431             a33=-a33
14432             do l=1,4
14433               do k=1,3
14434                 agg(k,l)=-agg(k,l)
14435                 aggi(k,l)=-aggi(k,l)
14436                 aggi1(k,l)=-aggi1(k,l)
14437                 aggj(k,l)=-aggj(k,l)
14438                 aggj1(k,l)=-aggj1(k,l)
14439               enddo
14440             enddo
14441           endif
14442           ENDIF ! WCORR
14443           IF (wel_loc.gt.0.0d0) THEN
14444 ! Contribution to the local-electrostatic energy coming from the i-j pair
14445           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14446            +a33*muij(4)
14447 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14448
14449           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14450                   'eelloc',i,j,eel_loc_ij
14451 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14452
14453           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14454 ! Partial derivatives in virtual-bond dihedral angles gamma
14455           if (i.gt.1) &
14456           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14457                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14458                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14459                  *sss_ele_cut
14460           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14461                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14462                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14463                  *sss_ele_cut
14464            xtemp(1)=xj
14465            xtemp(2)=yj
14466            xtemp(3)=zj
14467
14468 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14469           do l=1,3
14470             ggg(l)=(agg(l,1)*muij(1)+ &
14471                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14472             *sss_ele_cut &
14473              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14474
14475             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14476             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14477 !grad            ghalf=0.5d0*ggg(l)
14478 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14479 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14480           enddo
14481 !grad          do k=i+1,j2
14482 !grad            do l=1,3
14483 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14484 !grad            enddo
14485 !grad          enddo
14486 ! Remaining derivatives of eello
14487           do l=1,3
14488             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14489                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14490             *sss_ele_cut
14491
14492             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14493                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14494             *sss_ele_cut
14495
14496             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14497                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14498             *sss_ele_cut
14499
14500             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14501                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14502             *sss_ele_cut
14503
14504           enddo
14505           ENDIF
14506 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14507 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14508           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14509              .and. num_conti.le.maxconts) then
14510 !            write (iout,*) i,j," entered corr"
14511 !
14512 ! Calculate the contact function. The ith column of the array JCONT will
14513 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14514 ! greater than I). The arrays FACONT and GACONT will contain the values of
14515 ! the contact function and its derivative.
14516 !           r0ij=1.02D0*rpp(iteli,itelj)
14517 !           r0ij=1.11D0*rpp(iteli,itelj)
14518             r0ij=2.20D0*rpp(iteli,itelj)
14519 !           r0ij=1.55D0*rpp(iteli,itelj)
14520             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14521 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14522             if (fcont.gt.0.0D0) then
14523               num_conti=num_conti+1
14524               if (num_conti.gt.maxconts) then
14525 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14526                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14527                                ' will skip next contacts for this conf.',num_conti
14528               else
14529                 jcont_hb(num_conti,i)=j
14530 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14531 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14532                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14533                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14534 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14535 !  terms.
14536                 d_cont(num_conti,i)=rij
14537 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14538 !     --- Electrostatic-interaction matrix ---
14539                 a_chuj(1,1,num_conti,i)=a22
14540                 a_chuj(1,2,num_conti,i)=a23
14541                 a_chuj(2,1,num_conti,i)=a32
14542                 a_chuj(2,2,num_conti,i)=a33
14543 !     --- Gradient of rij
14544                 do kkk=1,3
14545                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14546                 enddo
14547                 kkll=0
14548                 do k=1,2
14549                   do l=1,2
14550                     kkll=kkll+1
14551                     do m=1,3
14552                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14553                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14554                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14555                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14556                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14557                     enddo
14558                   enddo
14559                 enddo
14560                 ENDIF
14561                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14562 ! Calculate contact energies
14563                 cosa4=4.0D0*cosa
14564                 wij=cosa-3.0D0*cosb*cosg
14565                 cosbg1=cosb+cosg
14566                 cosbg2=cosb-cosg
14567 !               fac3=dsqrt(-ael6i)/r0ij**3
14568                 fac3=dsqrt(-ael6i)*r3ij
14569 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14570                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14571                 if (ees0tmp.gt.0) then
14572                   ees0pij=dsqrt(ees0tmp)
14573                 else
14574                   ees0pij=0
14575                 endif
14576 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14577                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14578                 if (ees0tmp.gt.0) then
14579                   ees0mij=dsqrt(ees0tmp)
14580                 else
14581                   ees0mij=0
14582                 endif
14583 !               ees0mij=0.0D0
14584                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14585                      *sss_ele_cut
14586
14587                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14588                      *sss_ele_cut
14589
14590 ! Diagnostics. Comment out or remove after debugging!
14591 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14592 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14593 !               ees0m(num_conti,i)=0.0D0
14594 ! End diagnostics.
14595 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14596 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14597 ! Angular derivatives of the contact function
14598                 ees0pij1=fac3/ees0pij
14599                 ees0mij1=fac3/ees0mij
14600                 fac3p=-3.0D0*fac3*rrmij
14601                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14602                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14603 !               ees0mij1=0.0D0
14604                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14605                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14606                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14607                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14608                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14609                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14610                 ecosap=ecosa1+ecosa2
14611                 ecosbp=ecosb1+ecosb2
14612                 ecosgp=ecosg1+ecosg2
14613                 ecosam=ecosa1-ecosa2
14614                 ecosbm=ecosb1-ecosb2
14615                 ecosgm=ecosg1-ecosg2
14616 ! Diagnostics
14617 !               ecosap=ecosa1
14618 !               ecosbp=ecosb1
14619 !               ecosgp=ecosg1
14620 !               ecosam=0.0D0
14621 !               ecosbm=0.0D0
14622 !               ecosgm=0.0D0
14623 ! End diagnostics
14624                 facont_hb(num_conti,i)=fcont
14625                 fprimcont=fprimcont/rij
14626 !d              facont_hb(num_conti,i)=1.0D0
14627 ! Following line is for diagnostics.
14628 !d              fprimcont=0.0D0
14629                 do k=1,3
14630                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14631                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14632                 enddo
14633                 do k=1,3
14634                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14635                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14636                 enddo
14637 !                gggp(1)=gggp(1)+ees0pijp*xj
14638 !                gggp(2)=gggp(2)+ees0pijp*yj
14639 !                gggp(3)=gggp(3)+ees0pijp*zj
14640 !                gggm(1)=gggm(1)+ees0mijp*xj
14641 !                gggm(2)=gggm(2)+ees0mijp*yj
14642 !                gggm(3)=gggm(3)+ees0mijp*zj
14643                 gggp(1)=gggp(1)+ees0pijp*xj &
14644                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14645                 gggp(2)=gggp(2)+ees0pijp*yj &
14646                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14647                 gggp(3)=gggp(3)+ees0pijp*zj &
14648                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14649
14650                 gggm(1)=gggm(1)+ees0mijp*xj &
14651                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14652
14653                 gggm(2)=gggm(2)+ees0mijp*yj &
14654                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14655
14656                 gggm(3)=gggm(3)+ees0mijp*zj &
14657                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14658
14659 ! Derivatives due to the contact function
14660                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14661                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14662                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14663                 do k=1,3
14664 !
14665 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14666 !          following the change of gradient-summation algorithm.
14667 !
14668 !grad                  ghalfp=0.5D0*gggp(k)
14669 !grad                  ghalfm=0.5D0*gggm(k)
14670 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14671 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14672 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14673 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14674 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14675 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14676 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14677 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14678 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14679 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14680 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14681 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14682 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14683 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14684                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14685                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14686                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14687                      *sss_ele_cut
14688
14689                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14690                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14691                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14692                      *sss_ele_cut
14693
14694                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14695                      *sss_ele_cut
14696
14697                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14698                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14699                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14700                      *sss_ele_cut
14701
14702                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14703                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14704                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14705                      *sss_ele_cut
14706
14707                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14708                      *sss_ele_cut
14709
14710                 enddo
14711               ENDIF ! wcorr
14712               endif  ! num_conti.le.maxconts
14713             endif  ! fcont.gt.0
14714           endif    ! j.gt.i+1
14715           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14716             do k=1,4
14717               do l=1,3
14718                 ghalf=0.5d0*agg(l,k)
14719                 aggi(l,k)=aggi(l,k)+ghalf
14720                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14721                 aggj(l,k)=aggj(l,k)+ghalf
14722               enddo
14723             enddo
14724             if (j.eq.nres-1 .and. i.lt.j-2) then
14725               do k=1,4
14726                 do l=1,3
14727                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14728                 enddo
14729               enddo
14730             endif
14731           endif
14732  128      continue
14733 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14734       return
14735       end subroutine eelecij_scale
14736 !-----------------------------------------------------------------------------
14737       subroutine evdwpp_short(evdw1)
14738 !
14739 ! Compute Evdwpp
14740 !
14741 !      implicit real*8 (a-h,o-z)
14742 !      include 'DIMENSIONS'
14743 !      include 'COMMON.CONTROL'
14744 !      include 'COMMON.IOUNITS'
14745 !      include 'COMMON.GEO'
14746 !      include 'COMMON.VAR'
14747 !      include 'COMMON.LOCAL'
14748 !      include 'COMMON.CHAIN'
14749 !      include 'COMMON.DERIV'
14750 !      include 'COMMON.INTERACT'
14751 !      include 'COMMON.CONTACTS'
14752 !      include 'COMMON.TORSION'
14753 !      include 'COMMON.VECTORS'
14754 !      include 'COMMON.FFIELD'
14755       real(kind=8),dimension(3) :: ggg
14756 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14757 #ifdef MOMENT
14758       real(kind=8) :: scal_el=1.0d0
14759 #else
14760       real(kind=8) :: scal_el=0.5d0
14761 #endif
14762 !el local variables
14763       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14764       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14765       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14766                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14767                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14768       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14769                     dist_temp, dist_init,sss_grad
14770       integer xshift,yshift,zshift
14771
14772
14773       evdw1=0.0D0
14774 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14775 !     & " iatel_e_vdw",iatel_e_vdw
14776       call flush(iout)
14777       do i=iatel_s_vdw,iatel_e_vdw
14778         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
14779         dxi=dc(1,i)
14780         dyi=dc(2,i)
14781         dzi=dc(3,i)
14782         dx_normi=dc_norm(1,i)
14783         dy_normi=dc_norm(2,i)
14784         dz_normi=dc_norm(3,i)
14785         xmedi=c(1,i)+0.5d0*dxi
14786         ymedi=c(2,i)+0.5d0*dyi
14787         zmedi=c(3,i)+0.5d0*dzi
14788           xmedi=dmod(xmedi,boxxsize)
14789           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14790           ymedi=dmod(ymedi,boxysize)
14791           if (ymedi.lt.0) ymedi=ymedi+boxysize
14792           zmedi=dmod(zmedi,boxzsize)
14793           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14794         num_conti=0
14795 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14796 !     &   ' ielend',ielend_vdw(i)
14797         call flush(iout)
14798         do j=ielstart_vdw(i),ielend_vdw(i)
14799           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14800 !el          ind=ind+1
14801           iteli=itel(i)
14802           itelj=itel(j)
14803           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14804           aaa=app(iteli,itelj)
14805           bbb=bpp(iteli,itelj)
14806           dxj=dc(1,j)
14807           dyj=dc(2,j)
14808           dzj=dc(3,j)
14809           dx_normj=dc_norm(1,j)
14810           dy_normj=dc_norm(2,j)
14811           dz_normj=dc_norm(3,j)
14812 !          xj=c(1,j)+0.5D0*dxj-xmedi
14813 !          yj=c(2,j)+0.5D0*dyj-ymedi
14814 !          zj=c(3,j)+0.5D0*dzj-zmedi
14815           xj=c(1,j)+0.5D0*dxj
14816           yj=c(2,j)+0.5D0*dyj
14817           zj=c(3,j)+0.5D0*dzj
14818           xj=mod(xj,boxxsize)
14819           if (xj.lt.0) xj=xj+boxxsize
14820           yj=mod(yj,boxysize)
14821           if (yj.lt.0) yj=yj+boxysize
14822           zj=mod(zj,boxzsize)
14823           if (zj.lt.0) zj=zj+boxzsize
14824       isubchap=0
14825       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14826       xj_safe=xj
14827       yj_safe=yj
14828       zj_safe=zj
14829       do xshift=-1,1
14830       do yshift=-1,1
14831       do zshift=-1,1
14832           xj=xj_safe+xshift*boxxsize
14833           yj=yj_safe+yshift*boxysize
14834           zj=zj_safe+zshift*boxzsize
14835           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14836           if(dist_temp.lt.dist_init) then
14837             dist_init=dist_temp
14838             xj_temp=xj
14839             yj_temp=yj
14840             zj_temp=zj
14841             isubchap=1
14842           endif
14843        enddo
14844        enddo
14845        enddo
14846        if (isubchap.eq.1) then
14847 !C          print *,i,j
14848           xj=xj_temp-xmedi
14849           yj=yj_temp-ymedi
14850           zj=zj_temp-zmedi
14851        else
14852           xj=xj_safe-xmedi
14853           yj=yj_safe-ymedi
14854           zj=zj_safe-zmedi
14855        endif
14856
14857           rij=xj*xj+yj*yj+zj*zj
14858           rrmij=1.0D0/rij
14859           rij=dsqrt(rij)
14860           sss=sscale(rij/rpp(iteli,itelj))
14861             sss_ele_cut=sscale_ele(rij)
14862             sss_ele_grad=sscagrad_ele(rij)
14863             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14864             if (sss_ele_cut.le.0.0) cycle
14865           if (sss.gt.0.0d0) then
14866             rmij=1.0D0/rij
14867             r3ij=rrmij*rmij
14868             r6ij=r3ij*r3ij
14869             ev1=aaa*r6ij*r6ij
14870 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14871             if (j.eq.i+2) ev1=scal_el*ev1
14872             ev2=bbb*r6ij
14873             evdwij=ev1+ev2
14874             if (energy_dec) then
14875               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14876             endif
14877             evdw1=evdw1+evdwij*sss*sss_ele_cut
14878 !
14879 ! Calculate contributions to the Cartesian gradient.
14880 !
14881             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
14882 !            ggg(1)=facvdw*xj
14883 !            ggg(2)=facvdw*yj
14884 !            ggg(3)=facvdw*zj
14885           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
14886           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14887           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
14888           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14889           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
14890           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14891
14892             do k=1,3
14893               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14894               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14895             enddo
14896           endif
14897         enddo ! j
14898       enddo   ! i
14899       return
14900       end subroutine evdwpp_short
14901 !-----------------------------------------------------------------------------
14902       subroutine escp_long(evdw2,evdw2_14)
14903 !
14904 ! This subroutine calculates the excluded-volume interaction energy between
14905 ! peptide-group centers and side chains and its gradient in virtual-bond and
14906 ! side-chain vectors.
14907 !
14908 !      implicit real*8 (a-h,o-z)
14909 !      include 'DIMENSIONS'
14910 !      include 'COMMON.GEO'
14911 !      include 'COMMON.VAR'
14912 !      include 'COMMON.LOCAL'
14913 !      include 'COMMON.CHAIN'
14914 !      include 'COMMON.DERIV'
14915 !      include 'COMMON.INTERACT'
14916 !      include 'COMMON.FFIELD'
14917 !      include 'COMMON.IOUNITS'
14918 !      include 'COMMON.CONTROL'
14919       real(kind=8),dimension(3) :: ggg
14920 !el local variables
14921       integer :: i,iint,j,k,iteli,itypj,subchap
14922       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
14923       real(kind=8) :: evdw2,evdw2_14,evdwij
14924       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14925                     dist_temp, dist_init
14926
14927       evdw2=0.0D0
14928       evdw2_14=0.0d0
14929 !d    print '(a)','Enter ESCP'
14930 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
14931       do i=iatscp_s,iatscp_e
14932         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14933         iteli=itel(i)
14934         xi=0.5D0*(c(1,i)+c(1,i+1))
14935         yi=0.5D0*(c(2,i)+c(2,i+1))
14936         zi=0.5D0*(c(3,i)+c(3,i+1))
14937           xi=mod(xi,boxxsize)
14938           if (xi.lt.0) xi=xi+boxxsize
14939           yi=mod(yi,boxysize)
14940           if (yi.lt.0) yi=yi+boxysize
14941           zi=mod(zi,boxzsize)
14942           if (zi.lt.0) zi=zi+boxzsize
14943
14944         do iint=1,nscp_gr(i)
14945
14946         do j=iscpstart(i,iint),iscpend(i,iint)
14947           itypj=itype(j,1)
14948           if (itypj.eq.ntyp1) cycle
14949 ! Uncomment following three lines for SC-p interactions
14950 !         xj=c(1,nres+j)-xi
14951 !         yj=c(2,nres+j)-yi
14952 !         zj=c(3,nres+j)-zi
14953 ! Uncomment following three lines for Ca-p interactions
14954           xj=c(1,j)
14955           yj=c(2,j)
14956           zj=c(3,j)
14957           xj=mod(xj,boxxsize)
14958           if (xj.lt.0) xj=xj+boxxsize
14959           yj=mod(yj,boxysize)
14960           if (yj.lt.0) yj=yj+boxysize
14961           zj=mod(zj,boxzsize)
14962           if (zj.lt.0) zj=zj+boxzsize
14963       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14964       xj_safe=xj
14965       yj_safe=yj
14966       zj_safe=zj
14967       subchap=0
14968       do xshift=-1,1
14969       do yshift=-1,1
14970       do zshift=-1,1
14971           xj=xj_safe+xshift*boxxsize
14972           yj=yj_safe+yshift*boxysize
14973           zj=zj_safe+zshift*boxzsize
14974           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
14975           if(dist_temp.lt.dist_init) then
14976             dist_init=dist_temp
14977             xj_temp=xj
14978             yj_temp=yj
14979             zj_temp=zj
14980             subchap=1
14981           endif
14982        enddo
14983        enddo
14984        enddo
14985        if (subchap.eq.1) then
14986           xj=xj_temp-xi
14987           yj=yj_temp-yi
14988           zj=zj_temp-zi
14989        else
14990           xj=xj_safe-xi
14991           yj=yj_safe-yi
14992           zj=zj_safe-zi
14993        endif
14994           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14995
14996           rij=dsqrt(1.0d0/rrij)
14997             sss_ele_cut=sscale_ele(rij)
14998             sss_ele_grad=sscagrad_ele(rij)
14999 !            print *,sss_ele_cut,sss_ele_grad,&
15000 !            (rij),r_cut_ele,rlamb_ele
15001             if (sss_ele_cut.le.0.0) cycle
15002           sss=sscale((rij/rscp(itypj,iteli)))
15003           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15004           if (sss.lt.1.0d0) then
15005
15006             fac=rrij**expon2
15007             e1=fac*fac*aad(itypj,iteli)
15008             e2=fac*bad(itypj,iteli)
15009             if (iabs(j-i) .le. 2) then
15010               e1=scal14*e1
15011               e2=scal14*e2
15012               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15013             endif
15014             evdwij=e1+e2
15015             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15016             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15017                 'evdw2',i,j,sss,evdwij
15018 !
15019 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15020 !
15021             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15022             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15023             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15024             ggg(1)=xj*fac
15025             ggg(2)=yj*fac
15026             ggg(3)=zj*fac
15027 ! Uncomment following three lines for SC-p interactions
15028 !           do k=1,3
15029 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15030 !           enddo
15031 ! Uncomment following line for SC-p interactions
15032 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15033             do k=1,3
15034               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15035               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15036             enddo
15037           endif
15038         enddo
15039
15040         enddo ! iint
15041       enddo ! i
15042       do i=1,nct
15043         do j=1,3
15044           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15045           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15046           gradx_scp(j,i)=expon*gradx_scp(j,i)
15047         enddo
15048       enddo
15049 !******************************************************************************
15050 !
15051 !                              N O T E !!!
15052 !
15053 ! To save time the factor EXPON has been extracted from ALL components
15054 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15055 ! use!
15056 !
15057 !******************************************************************************
15058       return
15059       end subroutine escp_long
15060 !-----------------------------------------------------------------------------
15061       subroutine escp_short(evdw2,evdw2_14)
15062 !
15063 ! This subroutine calculates the excluded-volume interaction energy between
15064 ! peptide-group centers and side chains and its gradient in virtual-bond and
15065 ! side-chain vectors.
15066 !
15067 !      implicit real*8 (a-h,o-z)
15068 !      include 'DIMENSIONS'
15069 !      include 'COMMON.GEO'
15070 !      include 'COMMON.VAR'
15071 !      include 'COMMON.LOCAL'
15072 !      include 'COMMON.CHAIN'
15073 !      include 'COMMON.DERIV'
15074 !      include 'COMMON.INTERACT'
15075 !      include 'COMMON.FFIELD'
15076 !      include 'COMMON.IOUNITS'
15077 !      include 'COMMON.CONTROL'
15078       real(kind=8),dimension(3) :: ggg
15079 !el local variables
15080       integer :: i,iint,j,k,iteli,itypj,subchap
15081       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15082       real(kind=8) :: evdw2,evdw2_14,evdwij
15083       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15084                     dist_temp, dist_init
15085
15086       evdw2=0.0D0
15087       evdw2_14=0.0d0
15088 !d    print '(a)','Enter ESCP'
15089 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15090       do i=iatscp_s,iatscp_e
15091         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15092         iteli=itel(i)
15093         xi=0.5D0*(c(1,i)+c(1,i+1))
15094         yi=0.5D0*(c(2,i)+c(2,i+1))
15095         zi=0.5D0*(c(3,i)+c(3,i+1))
15096           xi=mod(xi,boxxsize)
15097           if (xi.lt.0) xi=xi+boxxsize
15098           yi=mod(yi,boxysize)
15099           if (yi.lt.0) yi=yi+boxysize
15100           zi=mod(zi,boxzsize)
15101           if (zi.lt.0) zi=zi+boxzsize
15102
15103         do iint=1,nscp_gr(i)
15104
15105         do j=iscpstart(i,iint),iscpend(i,iint)
15106           itypj=itype(j,1)
15107           if (itypj.eq.ntyp1) cycle
15108 ! Uncomment following three lines for SC-p interactions
15109 !         xj=c(1,nres+j)-xi
15110 !         yj=c(2,nres+j)-yi
15111 !         zj=c(3,nres+j)-zi
15112 ! Uncomment following three lines for Ca-p interactions
15113 !          xj=c(1,j)-xi
15114 !          yj=c(2,j)-yi
15115 !          zj=c(3,j)-zi
15116           xj=c(1,j)
15117           yj=c(2,j)
15118           zj=c(3,j)
15119           xj=mod(xj,boxxsize)
15120           if (xj.lt.0) xj=xj+boxxsize
15121           yj=mod(yj,boxysize)
15122           if (yj.lt.0) yj=yj+boxysize
15123           zj=mod(zj,boxzsize)
15124           if (zj.lt.0) zj=zj+boxzsize
15125       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15126       xj_safe=xj
15127       yj_safe=yj
15128       zj_safe=zj
15129       subchap=0
15130       do xshift=-1,1
15131       do yshift=-1,1
15132       do zshift=-1,1
15133           xj=xj_safe+xshift*boxxsize
15134           yj=yj_safe+yshift*boxysize
15135           zj=zj_safe+zshift*boxzsize
15136           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15137           if(dist_temp.lt.dist_init) then
15138             dist_init=dist_temp
15139             xj_temp=xj
15140             yj_temp=yj
15141             zj_temp=zj
15142             subchap=1
15143           endif
15144        enddo
15145        enddo
15146        enddo
15147        if (subchap.eq.1) then
15148           xj=xj_temp-xi
15149           yj=yj_temp-yi
15150           zj=zj_temp-zi
15151        else
15152           xj=xj_safe-xi
15153           yj=yj_safe-yi
15154           zj=zj_safe-zi
15155        endif
15156
15157           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15158           rij=dsqrt(1.0d0/rrij)
15159             sss_ele_cut=sscale_ele(rij)
15160             sss_ele_grad=sscagrad_ele(rij)
15161 !            print *,sss_ele_cut,sss_ele_grad,&
15162 !            (rij),r_cut_ele,rlamb_ele
15163             if (sss_ele_cut.le.0.0) cycle
15164           sss=sscale(rij/rscp(itypj,iteli))
15165           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15166           if (sss.gt.0.0d0) then
15167
15168             fac=rrij**expon2
15169             e1=fac*fac*aad(itypj,iteli)
15170             e2=fac*bad(itypj,iteli)
15171             if (iabs(j-i) .le. 2) then
15172               e1=scal14*e1
15173               e2=scal14*e2
15174               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15175             endif
15176             evdwij=e1+e2
15177             evdw2=evdw2+evdwij*sss*sss_ele_cut
15178             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15179                 'evdw2',i,j,sss,evdwij
15180 !
15181 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15182 !
15183             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15184             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15185             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15186
15187             ggg(1)=xj*fac
15188             ggg(2)=yj*fac
15189             ggg(3)=zj*fac
15190 ! Uncomment following three lines for SC-p interactions
15191 !           do k=1,3
15192 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15193 !           enddo
15194 ! Uncomment following line for SC-p interactions
15195 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15196             do k=1,3
15197               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15198               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15199             enddo
15200           endif
15201         enddo
15202
15203         enddo ! iint
15204       enddo ! i
15205       do i=1,nct
15206         do j=1,3
15207           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15208           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15209           gradx_scp(j,i)=expon*gradx_scp(j,i)
15210         enddo
15211       enddo
15212 !******************************************************************************
15213 !
15214 !                              N O T E !!!
15215 !
15216 ! To save time the factor EXPON has been extracted from ALL components
15217 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15218 ! use!
15219 !
15220 !******************************************************************************
15221       return
15222       end subroutine escp_short
15223 !-----------------------------------------------------------------------------
15224 ! energy_p_new-sep_barrier.F
15225 !-----------------------------------------------------------------------------
15226       subroutine sc_grad_scale(scalfac)
15227 !      implicit real*8 (a-h,o-z)
15228       use calc_data
15229 !      include 'DIMENSIONS'
15230 !      include 'COMMON.CHAIN'
15231 !      include 'COMMON.DERIV'
15232 !      include 'COMMON.CALC'
15233 !      include 'COMMON.IOUNITS'
15234       real(kind=8),dimension(3) :: dcosom1,dcosom2
15235       real(kind=8) :: scalfac
15236 !el local variables
15237 !      integer :: i,j,k,l
15238
15239       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15240       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15241       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15242            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15243 ! diagnostics only
15244 !      eom1=0.0d0
15245 !      eom2=0.0d0
15246 !      eom12=evdwij*eps1_om12
15247 ! end diagnostics
15248 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15249 !     &  " sigder",sigder
15250 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15251 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15252       do k=1,3
15253         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15254         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15255       enddo
15256       do k=1,3
15257         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15258          *sss_ele_cut
15259       enddo
15260 !      write (iout,*) "gg",(gg(k),k=1,3)
15261       do k=1,3
15262         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15263                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15264                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15265                  *sss_ele_cut
15266         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15267                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15268                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15269          *sss_ele_cut
15270 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15271 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15272 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15273 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15274       enddo
15275 !
15276 ! Calculate the components of the gradient in DC and X
15277 !
15278       do l=1,3
15279         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15280         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15281       enddo
15282       return
15283       end subroutine sc_grad_scale
15284 !-----------------------------------------------------------------------------
15285 ! energy_split-sep.F
15286 !-----------------------------------------------------------------------------
15287       subroutine etotal_long(energia)
15288 !
15289 ! Compute the long-range slow-varying contributions to the energy
15290 !
15291 !      implicit real*8 (a-h,o-z)
15292 !      include 'DIMENSIONS'
15293       use MD_data, only: totT,usampl,eq_time
15294 #ifndef ISNAN
15295       external proc_proc
15296 #ifdef WINPGI
15297 !MS$ATTRIBUTES C ::  proc_proc
15298 #endif
15299 #endif
15300 #ifdef MPI
15301       include "mpif.h"
15302       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15303 #endif
15304 !      include 'COMMON.SETUP'
15305 !      include 'COMMON.IOUNITS'
15306 !      include 'COMMON.FFIELD'
15307 !      include 'COMMON.DERIV'
15308 !      include 'COMMON.INTERACT'
15309 !      include 'COMMON.SBRIDGE'
15310 !      include 'COMMON.CHAIN'
15311 !      include 'COMMON.VAR'
15312 !      include 'COMMON.LOCAL'
15313 !      include 'COMMON.MD'
15314       real(kind=8),dimension(0:n_ene) :: energia
15315 !el local variables
15316       integer :: i,n_corr,n_corr1,ierror,ierr
15317       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15318                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15319                   ecorr,ecorr5,ecorr6,eturn6,time00
15320 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15321 !elwrite(iout,*)"in etotal long"
15322
15323       if (modecalc.eq.12.or.modecalc.eq.14) then
15324 #ifdef MPI
15325 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15326 #else
15327         call int_from_cart1(.false.)
15328 #endif
15329       endif
15330 !elwrite(iout,*)"in etotal long"
15331
15332 #ifdef MPI
15333 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15334 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15335       call flush(iout)
15336       if (nfgtasks.gt.1) then
15337         time00=MPI_Wtime()
15338 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15339         if (fg_rank.eq.0) then
15340           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15341 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15342 !          call flush(iout)
15343 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15344 ! FG slaves as WEIGHTS array.
15345           weights_(1)=wsc
15346           weights_(2)=wscp
15347           weights_(3)=welec
15348           weights_(4)=wcorr
15349           weights_(5)=wcorr5
15350           weights_(6)=wcorr6
15351           weights_(7)=wel_loc
15352           weights_(8)=wturn3
15353           weights_(9)=wturn4
15354           weights_(10)=wturn6
15355           weights_(11)=wang
15356           weights_(12)=wscloc
15357           weights_(13)=wtor
15358           weights_(14)=wtor_d
15359           weights_(15)=wstrain
15360           weights_(16)=wvdwpp
15361           weights_(17)=wbond
15362           weights_(18)=scal14
15363           weights_(21)=wsccor
15364 ! FG Master broadcasts the WEIGHTS_ array
15365           call MPI_Bcast(weights_(1),n_ene,&
15366               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15367         else
15368 ! FG slaves receive the WEIGHTS array
15369           call MPI_Bcast(weights(1),n_ene,&
15370               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15371           wsc=weights(1)
15372           wscp=weights(2)
15373           welec=weights(3)
15374           wcorr=weights(4)
15375           wcorr5=weights(5)
15376           wcorr6=weights(6)
15377           wel_loc=weights(7)
15378           wturn3=weights(8)
15379           wturn4=weights(9)
15380           wturn6=weights(10)
15381           wang=weights(11)
15382           wscloc=weights(12)
15383           wtor=weights(13)
15384           wtor_d=weights(14)
15385           wstrain=weights(15)
15386           wvdwpp=weights(16)
15387           wbond=weights(17)
15388           scal14=weights(18)
15389           wsccor=weights(21)
15390         endif
15391         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15392           king,FG_COMM,IERR)
15393          time_Bcast=time_Bcast+MPI_Wtime()-time00
15394          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15395 !        call chainbuild_cart
15396 !        call int_from_cart1(.false.)
15397       endif
15398 !      write (iout,*) 'Processor',myrank,
15399 !     &  ' calling etotal_short ipot=',ipot
15400 !      call flush(iout)
15401 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15402 #endif
15403 !d    print *,'nnt=',nnt,' nct=',nct
15404 !
15405 !elwrite(iout,*)"in etotal long"
15406 ! Compute the side-chain and electrostatic interaction energy
15407 !
15408       goto (101,102,103,104,105,106) ipot
15409 ! Lennard-Jones potential.
15410   101 call elj_long(evdw)
15411 !d    print '(a)','Exit ELJ'
15412       goto 107
15413 ! Lennard-Jones-Kihara potential (shifted).
15414   102 call eljk_long(evdw)
15415       goto 107
15416 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15417   103 call ebp_long(evdw)
15418       goto 107
15419 ! Gay-Berne potential (shifted LJ, angular dependence).
15420   104 call egb_long(evdw)
15421       goto 107
15422 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15423   105 call egbv_long(evdw)
15424       goto 107
15425 ! Soft-sphere potential
15426   106 call e_softsphere(evdw)
15427 !
15428 ! Calculate electrostatic (H-bonding) energy of the main chain.
15429 !
15430   107 continue
15431       call vec_and_deriv
15432       if (ipot.lt.6) then
15433 #ifdef SPLITELE
15434          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15435              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15436              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15437              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15438 #else
15439          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15440              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15441              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15442              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15443 #endif
15444            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15445          else
15446             ees=0
15447             evdw1=0
15448             eel_loc=0
15449             eello_turn3=0
15450             eello_turn4=0
15451          endif
15452       else
15453 !        write (iout,*) "Soft-spheer ELEC potential"
15454         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15455          eello_turn4)
15456       endif
15457 !
15458 ! Calculate excluded-volume interaction energy between peptide groups
15459 ! and side chains.
15460 !
15461       if (ipot.lt.6) then
15462        if(wscp.gt.0d0) then
15463         call escp_long(evdw2,evdw2_14)
15464        else
15465         evdw2=0
15466         evdw2_14=0
15467        endif
15468       else
15469         call escp_soft_sphere(evdw2,evdw2_14)
15470       endif
15471 !
15472 ! 12/1/95 Multi-body terms
15473 !
15474       n_corr=0
15475       n_corr1=0
15476       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15477           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15478          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15479 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15480 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15481       else
15482          ecorr=0.0d0
15483          ecorr5=0.0d0
15484          ecorr6=0.0d0
15485          eturn6=0.0d0
15486       endif
15487       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15488          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15489       endif
15490 !
15491 ! If performing constraint dynamics, call the constraint energy
15492 !  after the equilibration time
15493       if(usampl.and.totT.gt.eq_time) then
15494          call EconstrQ
15495          call Econstr_back
15496       else
15497          Uconst=0.0d0
15498          Uconst_back=0.0d0
15499       endif
15500 !
15501 ! Sum the energies
15502 !
15503       do i=1,n_ene
15504         energia(i)=0.0d0
15505       enddo
15506       energia(1)=evdw
15507 #ifdef SCP14
15508       energia(2)=evdw2-evdw2_14
15509       energia(18)=evdw2_14
15510 #else
15511       energia(2)=evdw2
15512       energia(18)=0.0d0
15513 #endif
15514 #ifdef SPLITELE
15515       energia(3)=ees
15516       energia(16)=evdw1
15517 #else
15518       energia(3)=ees+evdw1
15519       energia(16)=0.0d0
15520 #endif
15521       energia(4)=ecorr
15522       energia(5)=ecorr5
15523       energia(6)=ecorr6
15524       energia(7)=eel_loc
15525       energia(8)=eello_turn3
15526       energia(9)=eello_turn4
15527       energia(10)=eturn6
15528       energia(20)=Uconst+Uconst_back
15529       call sum_energy(energia,.true.)
15530 !      write (iout,*) "Exit ETOTAL_LONG"
15531       call flush(iout)
15532       return
15533       end subroutine etotal_long
15534 !-----------------------------------------------------------------------------
15535       subroutine etotal_short(energia)
15536 !
15537 ! Compute the short-range fast-varying contributions to the energy
15538 !
15539 !      implicit real*8 (a-h,o-z)
15540 !      include 'DIMENSIONS'
15541 #ifndef ISNAN
15542       external proc_proc
15543 #ifdef WINPGI
15544 !MS$ATTRIBUTES C ::  proc_proc
15545 #endif
15546 #endif
15547 #ifdef MPI
15548       include "mpif.h"
15549       integer :: ierror,ierr
15550       real(kind=8),dimension(n_ene) :: weights_
15551       real(kind=8) :: time00
15552 #endif
15553 !      include 'COMMON.SETUP'
15554 !      include 'COMMON.IOUNITS'
15555 !      include 'COMMON.FFIELD'
15556 !      include 'COMMON.DERIV'
15557 !      include 'COMMON.INTERACT'
15558 !      include 'COMMON.SBRIDGE'
15559 !      include 'COMMON.CHAIN'
15560 !      include 'COMMON.VAR'
15561 !      include 'COMMON.LOCAL'
15562       real(kind=8),dimension(0:n_ene) :: energia
15563 !el local variables
15564       integer :: i,nres6
15565       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15566       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15567       nres6=6*nres
15568
15569 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15570 !      call flush(iout)
15571       if (modecalc.eq.12.or.modecalc.eq.14) then
15572 #ifdef MPI
15573         if (fg_rank.eq.0) call int_from_cart1(.false.)
15574 #else
15575         call int_from_cart1(.false.)
15576 #endif
15577       endif
15578 #ifdef MPI
15579 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15580 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15581 !      call flush(iout)
15582       if (nfgtasks.gt.1) then
15583         time00=MPI_Wtime()
15584 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15585         if (fg_rank.eq.0) then
15586           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15587 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15588 !          call flush(iout)
15589 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15590 ! FG slaves as WEIGHTS array.
15591           weights_(1)=wsc
15592           weights_(2)=wscp
15593           weights_(3)=welec
15594           weights_(4)=wcorr
15595           weights_(5)=wcorr5
15596           weights_(6)=wcorr6
15597           weights_(7)=wel_loc
15598           weights_(8)=wturn3
15599           weights_(9)=wturn4
15600           weights_(10)=wturn6
15601           weights_(11)=wang
15602           weights_(12)=wscloc
15603           weights_(13)=wtor
15604           weights_(14)=wtor_d
15605           weights_(15)=wstrain
15606           weights_(16)=wvdwpp
15607           weights_(17)=wbond
15608           weights_(18)=scal14
15609           weights_(21)=wsccor
15610 ! FG Master broadcasts the WEIGHTS_ array
15611           call MPI_Bcast(weights_(1),n_ene,&
15612               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15613         else
15614 ! FG slaves receive the WEIGHTS array
15615           call MPI_Bcast(weights(1),n_ene,&
15616               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15617           wsc=weights(1)
15618           wscp=weights(2)
15619           welec=weights(3)
15620           wcorr=weights(4)
15621           wcorr5=weights(5)
15622           wcorr6=weights(6)
15623           wel_loc=weights(7)
15624           wturn3=weights(8)
15625           wturn4=weights(9)
15626           wturn6=weights(10)
15627           wang=weights(11)
15628           wscloc=weights(12)
15629           wtor=weights(13)
15630           wtor_d=weights(14)
15631           wstrain=weights(15)
15632           wvdwpp=weights(16)
15633           wbond=weights(17)
15634           scal14=weights(18)
15635           wsccor=weights(21)
15636         endif
15637 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15638         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15639           king,FG_COMM,IERR)
15640 !        write (iout,*) "Processor",myrank," BROADCAST c"
15641         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15642           king,FG_COMM,IERR)
15643 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15644         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15645           king,FG_COMM,IERR)
15646 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15647         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15648           king,FG_COMM,IERR)
15649 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15650         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15651           king,FG_COMM,IERR)
15652 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15653         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15654           king,FG_COMM,IERR)
15655 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15656         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15657           king,FG_COMM,IERR)
15658 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15659         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15660           king,FG_COMM,IERR)
15661 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15662         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15663           king,FG_COMM,IERR)
15664          time_Bcast=time_Bcast+MPI_Wtime()-time00
15665 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15666       endif
15667 !      write (iout,*) 'Processor',myrank,
15668 !     &  ' calling etotal_short ipot=',ipot
15669 !      call flush(iout)
15670 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15671 #endif
15672 !      call int_from_cart1(.false.)
15673 !
15674 ! Compute the side-chain and electrostatic interaction energy
15675 !
15676       goto (101,102,103,104,105,106) ipot
15677 ! Lennard-Jones potential.
15678   101 call elj_short(evdw)
15679 !d    print '(a)','Exit ELJ'
15680       goto 107
15681 ! Lennard-Jones-Kihara potential (shifted).
15682   102 call eljk_short(evdw)
15683       goto 107
15684 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15685   103 call ebp_short(evdw)
15686       goto 107
15687 ! Gay-Berne potential (shifted LJ, angular dependence).
15688   104 call egb_short(evdw)
15689       goto 107
15690 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15691   105 call egbv_short(evdw)
15692       goto 107
15693 ! Soft-sphere potential - already dealt with in the long-range part
15694   106 evdw=0.0d0
15695 !  106 call e_softsphere_short(evdw)
15696 !
15697 ! Calculate electrostatic (H-bonding) energy of the main chain.
15698 !
15699   107 continue
15700 !
15701 ! Calculate the short-range part of Evdwpp
15702 !
15703       call evdwpp_short(evdw1)
15704 !
15705 ! Calculate the short-range part of ESCp
15706 !
15707       if (ipot.lt.6) then
15708         call escp_short(evdw2,evdw2_14)
15709       endif
15710 !
15711 ! Calculate the bond-stretching energy
15712 !
15713       call ebond(estr)
15714 !
15715 ! Calculate the disulfide-bridge and other energy and the contributions
15716 ! from other distance constraints.
15717       call edis(ehpb)
15718 !
15719 ! Calculate the virtual-bond-angle energy.
15720 !
15721       call ebend(ebe,ethetacnstr)
15722 !
15723 ! Calculate the SC local energy.
15724 !
15725       call vec_and_deriv
15726       call esc(escloc)
15727 !
15728 ! Calculate the virtual-bond torsional energy.
15729 !
15730       call etor(etors,edihcnstr)
15731 !
15732 ! 6/23/01 Calculate double-torsional energy
15733 !
15734       call etor_d(etors_d)
15735 !
15736 ! 21/5/07 Calculate local sicdechain correlation energy
15737 !
15738       if (wsccor.gt.0.0d0) then
15739         call eback_sc_corr(esccor)
15740       else
15741         esccor=0.0d0
15742       endif
15743 !
15744 ! Put energy components into an array
15745 !
15746       do i=1,n_ene
15747         energia(i)=0.0d0
15748       enddo
15749       energia(1)=evdw
15750 #ifdef SCP14
15751       energia(2)=evdw2-evdw2_14
15752       energia(18)=evdw2_14
15753 #else
15754       energia(2)=evdw2
15755       energia(18)=0.0d0
15756 #endif
15757 #ifdef SPLITELE
15758       energia(16)=evdw1
15759 #else
15760       energia(3)=evdw1
15761 #endif
15762       energia(11)=ebe
15763       energia(12)=escloc
15764       energia(13)=etors
15765       energia(14)=etors_d
15766       energia(15)=ehpb
15767       energia(17)=estr
15768       energia(19)=edihcnstr
15769       energia(21)=esccor
15770 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15771       call flush(iout)
15772       call sum_energy(energia,.true.)
15773 !      write (iout,*) "Exit ETOTAL_SHORT"
15774       call flush(iout)
15775       return
15776       end subroutine etotal_short
15777 !-----------------------------------------------------------------------------
15778 ! gnmr1.f
15779 !-----------------------------------------------------------------------------
15780       real(kind=8) function gnmr1(y,ymin,ymax)
15781 !      implicit none
15782       real(kind=8) :: y,ymin,ymax
15783       real(kind=8) :: wykl=4.0d0
15784       if (y.lt.ymin) then
15785         gnmr1=(ymin-y)**wykl/wykl
15786       else if (y.gt.ymax) then
15787         gnmr1=(y-ymax)**wykl/wykl
15788       else
15789         gnmr1=0.0d0
15790       endif
15791       return
15792       end function gnmr1
15793 !-----------------------------------------------------------------------------
15794       real(kind=8) function gnmr1prim(y,ymin,ymax)
15795 !      implicit none
15796       real(kind=8) :: y,ymin,ymax
15797       real(kind=8) :: wykl=4.0d0
15798       if (y.lt.ymin) then
15799         gnmr1prim=-(ymin-y)**(wykl-1)
15800       else if (y.gt.ymax) then
15801         gnmr1prim=(y-ymax)**(wykl-1)
15802       else
15803         gnmr1prim=0.0d0
15804       endif
15805       return
15806       end function gnmr1prim
15807 !----------------------------------------------------------------------------
15808       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
15809       real(kind=8) y,ymin,ymax,sigma
15810       real(kind=8) wykl /4.0d0/
15811       if (y.lt.ymin) then
15812         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
15813       else if (y.gt.ymax) then
15814         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
15815       else
15816         rlornmr1=0.0d0
15817       endif
15818       return
15819       end function rlornmr1
15820 !------------------------------------------------------------------------------
15821       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
15822       real(kind=8) y,ymin,ymax,sigma
15823       real(kind=8) wykl /4.0d0/
15824       if (y.lt.ymin) then
15825         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
15826         ((ymin-y)**wykl+sigma**wykl)**2
15827       else if (y.gt.ymax) then
15828         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
15829         ((y-ymax)**wykl+sigma**wykl)**2
15830       else
15831         rlornmr1prim=0.0d0
15832       endif
15833       return
15834       end function rlornmr1prim
15835
15836       real(kind=8) function harmonic(y,ymax)
15837 !      implicit none
15838       real(kind=8) :: y,ymax
15839       real(kind=8) :: wykl=2.0d0
15840       harmonic=(y-ymax)**wykl
15841       return
15842       end function harmonic
15843 !-----------------------------------------------------------------------------
15844       real(kind=8) function harmonicprim(y,ymax)
15845       real(kind=8) :: y,ymin,ymax
15846       real(kind=8) :: wykl=2.0d0
15847       harmonicprim=(y-ymax)*wykl
15848       return
15849       end function harmonicprim
15850 !-----------------------------------------------------------------------------
15851 ! gradient_p.F
15852 !-----------------------------------------------------------------------------
15853       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
15854
15855       use io_base, only:intout,briefout
15856 !      implicit real*8 (a-h,o-z)
15857 !      include 'DIMENSIONS'
15858 !      include 'COMMON.CHAIN'
15859 !      include 'COMMON.DERIV'
15860 !      include 'COMMON.VAR'
15861 !      include 'COMMON.INTERACT'
15862 !      include 'COMMON.FFIELD'
15863 !      include 'COMMON.MD'
15864 !      include 'COMMON.IOUNITS'
15865       real(kind=8),external :: ufparm
15866       integer :: uiparm(1)
15867       real(kind=8) :: urparm(1)
15868       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
15869       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
15870       integer :: n,nf,ind,ind1,i,k,j
15871 !
15872 ! This subroutine calculates total internal coordinate gradient.
15873 ! Depending on the number of function evaluations, either whole energy
15874 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
15875 ! internal coordinates are reevaluated or only the cartesian-in-internal
15876 ! coordinate derivatives are evaluated. The subroutine was designed to work
15877 ! with SUMSL.
15878 !
15879 !
15880       icg=mod(nf,2)+1
15881
15882 !d      print *,'grad',nf,icg
15883       if (nf-nfl+1) 20,30,40
15884    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
15885 !    write (iout,*) 'grad 20'
15886       if (nf.eq.0) return
15887       goto 40
15888    30 call var_to_geom(n,x)
15889       call chainbuild
15890 !    write (iout,*) 'grad 30'
15891 !
15892 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
15893 !
15894    40 call cartder
15895 !     write (iout,*) 'grad 40'
15896 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
15897 !
15898 ! Convert the Cartesian gradient into internal-coordinate gradient.
15899 !
15900       ind=0
15901       ind1=0
15902       do i=1,nres-2
15903         gthetai=0.0D0
15904         gphii=0.0D0
15905         do j=i+1,nres-1
15906           ind=ind+1
15907 !         ind=indmat(i,j)
15908 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
15909           do k=1,3
15910             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
15911           enddo
15912           do k=1,3
15913             gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
15914           enddo
15915         enddo
15916         do j=i+1,nres-1
15917           ind1=ind1+1
15918 !         ind1=indmat(i,j)
15919 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
15920           do k=1,3
15921             gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
15922             gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
15923           enddo
15924         enddo
15925         if (i.gt.1) g(i-1)=gphii
15926         if (n.gt.nphi) g(nphi+i)=gthetai
15927       enddo
15928       if (n.le.nphi+ntheta) goto 10
15929       do i=2,nres-1
15930         if (itype(i,1).ne.10) then
15931           galphai=0.0D0
15932           gomegai=0.0D0
15933           do k=1,3
15934             galphai=galphai+dxds(k,i)*gradx(k,i,icg)
15935           enddo
15936           do k=1,3
15937             gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
15938           enddo
15939           g(ialph(i,1))=galphai
15940           g(ialph(i,1)+nside)=gomegai
15941         endif
15942       enddo
15943 !
15944 ! Add the components corresponding to local energy terms.
15945 !
15946    10 continue
15947       do i=1,nvar
15948 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
15949         g(i)=g(i)+gloc(i,icg)
15950       enddo
15951 ! Uncomment following three lines for diagnostics.
15952 !d    call intout
15953 !elwrite(iout,*) "in gradient after calling intout"
15954 !d    call briefout(0,0.0d0)
15955 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
15956       return
15957       end subroutine gradient
15958 !-----------------------------------------------------------------------------
15959       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
15960
15961       use comm_chu
15962 !      implicit real*8 (a-h,o-z)
15963 !      include 'DIMENSIONS'
15964 !      include 'COMMON.DERIV'
15965 !      include 'COMMON.IOUNITS'
15966 !      include 'COMMON.GEO'
15967       integer :: n,nf
15968 !el      integer :: jjj
15969 !el      common /chuju/ jjj
15970       real(kind=8) :: energia(0:n_ene)
15971       integer :: uiparm(1)
15972       real(kind=8) :: urparm(1)
15973       real(kind=8) :: f
15974       real(kind=8),external :: ufparm
15975       real(kind=8),dimension(6*nres) :: x       !(maxvar) (maxvar=6*maxres)
15976 !     if (jjj.gt.0) then
15977 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15978 !     endif
15979       nfl=nf
15980       icg=mod(nf,2)+1
15981 !d      print *,'func',nf,nfl,icg
15982       call var_to_geom(n,x)
15983       call zerograd
15984       call chainbuild
15985 !d    write (iout,*) 'ETOTAL called from FUNC'
15986       call etotal(energia)
15987       call sum_gradient
15988       f=energia(0)
15989 !     if (jjj.gt.0) then
15990 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
15991 !       write (iout,*) 'f=',etot
15992 !       jjj=0
15993 !     endif
15994       return
15995       end subroutine func
15996 !-----------------------------------------------------------------------------
15997       subroutine cartgrad
15998 !      implicit real*8 (a-h,o-z)
15999 !      include 'DIMENSIONS'
16000       use energy_data
16001       use MD_data, only: totT,usampl,eq_time
16002 #ifdef MPI
16003       include 'mpif.h'
16004 #endif
16005 !      include 'COMMON.CHAIN'
16006 !      include 'COMMON.DERIV'
16007 !      include 'COMMON.VAR'
16008 !      include 'COMMON.INTERACT'
16009 !      include 'COMMON.FFIELD'
16010 !      include 'COMMON.MD'
16011 !      include 'COMMON.IOUNITS'
16012 !      include 'COMMON.TIME1'
16013 !
16014       integer :: i,j
16015
16016 ! This subrouting calculates total Cartesian coordinate gradient.
16017 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16018 !
16019 !el#define DEBUG
16020 #ifdef TIMING
16021       time00=MPI_Wtime()
16022 #endif
16023       icg=1
16024       call sum_gradient
16025 #ifdef TIMING
16026 #endif
16027 !el      write (iout,*) "After sum_gradient"
16028 #ifdef DEBUG
16029 !el      write (iout,*) "After sum_gradient"
16030       do i=1,nres-1
16031         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16032         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16033       enddo
16034 #endif
16035 ! If performing constraint dynamics, add the gradients of the constraint energy
16036       if(usampl.and.totT.gt.eq_time) then
16037          do i=1,nct
16038            do j=1,3
16039              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16040              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16041            enddo
16042          enddo
16043          do i=1,nres-3
16044            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16045          enddo
16046          do i=1,nres-2
16047            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16048          enddo
16049       endif
16050 !elwrite (iout,*) "After sum_gradient"
16051 #ifdef TIMING
16052       time01=MPI_Wtime()
16053 #endif
16054       call intcartderiv
16055 !elwrite (iout,*) "After sum_gradient"
16056 #ifdef TIMING
16057       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16058 #endif
16059 !     call checkintcartgrad
16060 !     write(iout,*) 'calling int_to_cart'
16061 #ifdef DEBUG
16062       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16063 #endif
16064       do i=0,nct
16065         do j=1,3
16066           gcart(j,i)=gradc(j,i,icg)
16067           gxcart(j,i)=gradx(j,i,icg)
16068         enddo
16069 #ifdef DEBUG
16070         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16071           (gxcart(j,i),j=1,3),gloc(i,icg)
16072 #endif
16073       enddo
16074 #ifdef TIMING
16075       time01=MPI_Wtime()
16076 #endif
16077       call int_to_cart
16078 #ifdef TIMING
16079       time_inttocart=time_inttocart+MPI_Wtime()-time01
16080 #endif
16081 #ifdef DEBUG
16082       write (iout,*) "gcart and gxcart after int_to_cart"
16083       do i=0,nres-1
16084         write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16085             (gxcart(j,i),j=1,3)
16086       enddo
16087 #endif
16088 #ifdef CARGRAD
16089 #ifdef DEBUG
16090       write (iout,*) "CARGRAD"
16091 #endif
16092       do i=nres,0,-1
16093         do j=1,3
16094           gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16095 !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16096         enddo
16097 !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16098 !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16099       enddo
16100 ! Correction: dummy residues
16101         if (nnt.gt.1) then
16102           do j=1,3
16103 !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16104             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16105           enddo
16106         endif
16107         if (nct.lt.nres) then
16108           do j=1,3
16109 !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16110             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16111           enddo
16112         endif
16113 #endif
16114 #ifdef TIMING
16115       time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16116 #endif
16117 !el#undef DEBUG
16118       return
16119       end subroutine cartgrad
16120 !-----------------------------------------------------------------------------
16121       subroutine zerograd
16122 !      implicit real*8 (a-h,o-z)
16123 !      include 'DIMENSIONS'
16124 !      include 'COMMON.DERIV'
16125 !      include 'COMMON.CHAIN'
16126 !      include 'COMMON.VAR'
16127 !      include 'COMMON.MD'
16128 !      include 'COMMON.SCCOR'
16129 !
16130 !el local variables
16131       integer :: i,j,intertyp,k
16132 ! Initialize Cartesian-coordinate gradient
16133 !
16134 !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16135 !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16136
16137 !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16138 !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16139 !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16140 !      allocate(gradcorr_long(3,nres))
16141 !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16142 !      allocate(gcorr6_turn_long(3,nres))
16143 !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16144
16145 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16146
16147 !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16148 !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16149
16150 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16151 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16152
16153 !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16154 !      allocate(gscloc(3,nres)) !(3,maxres)
16155 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16156
16157
16158
16159 !      common /deriv_scloc/
16160 !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16161 !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16162 !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))       !(3,maxres)
16163 !      common /mpgrad/
16164 !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16165
16166
16167
16168 !          gradc(j,i,icg)=0.0d0
16169 !          gradx(j,i,icg)=0.0d0
16170
16171 !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16172 !elwrite(iout,*) "icg",icg
16173       do i=-1,nres
16174         do j=1,3
16175           gvdwx(j,i)=0.0D0
16176           gradx_scp(j,i)=0.0D0
16177           gvdwc(j,i)=0.0D0
16178           gvdwc_scp(j,i)=0.0D0
16179           gvdwc_scpp(j,i)=0.0d0
16180           gelc(j,i)=0.0D0
16181           gelc_long(j,i)=0.0D0
16182           gradb(j,i)=0.0d0
16183           gradbx(j,i)=0.0d0
16184           gvdwpp(j,i)=0.0d0
16185           gel_loc(j,i)=0.0d0
16186           gel_loc_long(j,i)=0.0d0
16187           ghpbc(j,i)=0.0D0
16188           ghpbx(j,i)=0.0D0
16189           gcorr3_turn(j,i)=0.0d0
16190           gcorr4_turn(j,i)=0.0d0
16191           gradcorr(j,i)=0.0d0
16192           gradcorr_long(j,i)=0.0d0
16193           gradcorr5_long(j,i)=0.0d0
16194           gradcorr6_long(j,i)=0.0d0
16195           gcorr6_turn_long(j,i)=0.0d0
16196           gradcorr5(j,i)=0.0d0
16197           gradcorr6(j,i)=0.0d0
16198           gcorr6_turn(j,i)=0.0d0
16199           gsccorc(j,i)=0.0d0
16200           gsccorx(j,i)=0.0d0
16201           gradc(j,i,icg)=0.0d0
16202           gradx(j,i,icg)=0.0d0
16203           gscloc(j,i)=0.0d0
16204           gsclocx(j,i)=0.0d0
16205           gliptran(j,i)=0.0d0
16206           gliptranx(j,i)=0.0d0
16207           gliptranc(j,i)=0.0d0
16208           gshieldx(j,i)=0.0d0
16209           gshieldc(j,i)=0.0d0
16210           gshieldc_loc(j,i)=0.0d0
16211           gshieldx_ec(j,i)=0.0d0
16212           gshieldc_ec(j,i)=0.0d0
16213           gshieldc_loc_ec(j,i)=0.0d0
16214           gshieldx_t3(j,i)=0.0d0
16215           gshieldc_t3(j,i)=0.0d0
16216           gshieldc_loc_t3(j,i)=0.0d0
16217           gshieldx_t4(j,i)=0.0d0
16218           gshieldc_t4(j,i)=0.0d0
16219           gshieldc_loc_t4(j,i)=0.0d0
16220           gshieldx_ll(j,i)=0.0d0
16221           gshieldc_ll(j,i)=0.0d0
16222           gshieldc_loc_ll(j,i)=0.0d0
16223           gg_tube(j,i)=0.0d0
16224           gg_tube_sc(j,i)=0.0d0
16225           gradafm(j,i)=0.0d0
16226           gradb_nucl(j,i)=0.0d0
16227           gradbx_nucl(j,i)=0.0d0
16228           do intertyp=1,3
16229            gloc_sc(intertyp,i,icg)=0.0d0
16230           enddo
16231         enddo
16232       enddo
16233       do i=1,nres
16234        do j=1,maxcontsshi
16235        shield_list(j,i)=0
16236         do k=1,3
16237 !C           print *,i,j,k
16238            grad_shield_side(k,j,i)=0.0d0
16239            grad_shield_loc(k,j,i)=0.0d0
16240          enddo
16241        enddo
16242        ishield_list(i)=0
16243       enddo
16244
16245 !
16246 ! Initialize the gradient of local energy terms.
16247 !
16248 !      allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres)
16249 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16250 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16251 !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))    !(maxvar)(maxvar=6*maxres)
16252 !      allocate(gel_loc_turn3(nres))
16253 !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16254 !      allocate(gsccor_loc(nres))       !(maxres)
16255
16256       do i=1,4*nres
16257         gloc(i,icg)=0.0D0
16258       enddo
16259       do i=1,nres
16260         gel_loc_loc(i)=0.0d0
16261         gcorr_loc(i)=0.0d0
16262         g_corr5_loc(i)=0.0d0
16263         g_corr6_loc(i)=0.0d0
16264         gel_loc_turn3(i)=0.0d0
16265         gel_loc_turn4(i)=0.0d0
16266         gel_loc_turn6(i)=0.0d0
16267         gsccor_loc(i)=0.0d0
16268       enddo
16269 ! initialize gcart and gxcart
16270 !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16271       do i=0,nres
16272         do j=1,3
16273           gcart(j,i)=0.0d0
16274           gxcart(j,i)=0.0d0
16275         enddo
16276       enddo
16277       return
16278       end subroutine zerograd
16279 !-----------------------------------------------------------------------------
16280       real(kind=8) function fdum()
16281       fdum=0.0D0
16282       return
16283       end function fdum
16284 !-----------------------------------------------------------------------------
16285 ! intcartderiv.F
16286 !-----------------------------------------------------------------------------
16287       subroutine intcartderiv
16288 !      implicit real*8 (a-h,o-z)
16289 !      include 'DIMENSIONS'
16290 #ifdef MPI
16291       include 'mpif.h'
16292 #endif
16293 !      include 'COMMON.SETUP'
16294 !      include 'COMMON.CHAIN'
16295 !      include 'COMMON.VAR'
16296 !      include 'COMMON.GEO'
16297 !      include 'COMMON.INTERACT'
16298 !      include 'COMMON.DERIV'
16299 !      include 'COMMON.IOUNITS'
16300 !      include 'COMMON.LOCAL'
16301 !      include 'COMMON.SCCOR'
16302       real(kind=8) :: pi4,pi34
16303       real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16304       real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16305                     dcosomega,dsinomega !(3,3,maxres)
16306       real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16307
16308       integer :: i,j,k
16309       real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16310                   fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16311                   fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16312                   fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16313       integer :: nres2
16314       nres2=2*nres
16315
16316 !el from module energy-------------
16317 !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16318 !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16319 !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16320
16321 !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16322 !el      allocate(dsintau(3,3,3,0:nres2))
16323 !el      allocate(dtauangle(3,3,3,0:nres2))
16324 !el      allocate(domicron(3,2,2,0:nres2))
16325 !el      allocate(dcosomicron(3,2,2,0:nres2))
16326
16327
16328
16329 #if defined(MPI) && defined(PARINTDER)
16330       if (nfgtasks.gt.1 .and. me.eq.king) &
16331         call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16332 #endif
16333       pi4 = 0.5d0*pipol
16334       pi34 = 3*pi4
16335
16336 !      allocate(dtheta(3,2,nres))       !(3,2,maxres)
16337 !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16338
16339 !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16340       do i=1,nres
16341         do j=1,3
16342           dtheta(j,1,i)=0.0d0
16343           dtheta(j,2,i)=0.0d0
16344           dphi(j,1,i)=0.0d0
16345           dphi(j,2,i)=0.0d0
16346           dphi(j,3,i)=0.0d0
16347         enddo
16348       enddo
16349 ! Derivatives of theta's
16350 #if defined(MPI) && defined(PARINTDER)
16351 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16352       do i=max0(ithet_start-1,3),ithet_end
16353 #else
16354       do i=3,nres
16355 #endif
16356         cost=dcos(theta(i))
16357         sint=sqrt(1-cost*cost)
16358         do j=1,3
16359           dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16360           vbld(i-1)
16361           if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16362           dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16363           vbld(i)
16364           if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16365         enddo
16366       enddo
16367 #if defined(MPI) && defined(PARINTDER)
16368 ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16369       do i=max0(ithet_start-1,3),ithet_end
16370 #else
16371       do i=3,nres
16372 #endif
16373       if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16374         cost1=dcos(omicron(1,i))
16375         sint1=sqrt(1-cost1*cost1)
16376         cost2=dcos(omicron(2,i))
16377         sint2=sqrt(1-cost2*cost2)
16378        do j=1,3
16379 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16380           dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16381           cost1*dc_norm(j,i-2))/ &
16382           vbld(i-1)
16383           domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16384           dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16385           +cost1*(dc_norm(j,i-1+nres)))/ &
16386           vbld(i-1+nres)
16387           domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16388 !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16389 !C Looks messy but better than if in loop
16390           dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16391           +cost2*dc_norm(j,i-1))/ &
16392           vbld(i)
16393           domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16394           dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16395            +cost2*(-dc_norm(j,i-1+nres)))/ &
16396           vbld(i-1+nres)
16397 !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16398           domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16399         enddo
16400        endif
16401       enddo
16402 !elwrite(iout,*) "after vbld write"
16403 ! Derivatives of phi:
16404 ! If phi is 0 or 180 degrees, then the formulas
16405 ! have to be derived by power series expansion of the
16406 ! conventional formulas around 0 and 180.
16407 #ifdef PARINTDER
16408       do i=iphi1_start,iphi1_end
16409 #else
16410       do i=4,nres
16411 #endif
16412 !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16413 ! the conventional case
16414         sint=dsin(theta(i))
16415         sint1=dsin(theta(i-1))
16416         sing=dsin(phi(i))
16417         cost=dcos(theta(i))
16418         cost1=dcos(theta(i-1))
16419         cosg=dcos(phi(i))
16420         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16421         fac0=1.0d0/(sint1*sint)
16422         fac1=cost*fac0
16423         fac2=cost1*fac0
16424         fac3=cosg*cost1/(sint1*sint1)
16425         fac4=cosg*cost/(sint*sint)
16426 !    Obtaining the gamma derivatives from sine derivative
16427        if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16428            phi(i).gt.pi34.and.phi(i).le.pi.or. &
16429            phi(i).ge.-pi.and.phi(i).le.-pi34) then
16430          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16431          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16432          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16433          do j=1,3
16434             ctgt=cost/sint
16435             ctgt1=cost1/sint1
16436             cosg_inv=1.0d0/cosg
16437             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16438             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16439               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16440             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16441             dsinphi(j,2,i)= &
16442               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16443               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16444             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16445             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16446               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16447 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16448             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16449             endif
16450 ! Bug fixed 3/24/05 (AL)
16451          enddo
16452 !   Obtaining the gamma derivatives from cosine derivative
16453         else
16454            do j=1,3
16455            if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16456            dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16457            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16458            dc_norm(j,i-3))/vbld(i-2)
16459            dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16460            dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16461            dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16462            dcostheta(j,1,i)
16463            dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16464            dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16465            dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16466            dc_norm(j,i-1))/vbld(i)
16467            dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16468            endif
16469          enddo
16470         endif
16471       enddo
16472 !alculate derivative of Tauangle
16473 #ifdef PARINTDER
16474       do i=itau_start,itau_end
16475 #else
16476       do i=3,nres
16477 !elwrite(iout,*) " vecpr",i,nres
16478 #endif
16479        if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16480 !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16481 !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16482 !c dtauangle(j,intertyp,dervityp,residue number)
16483 !c INTERTYP=1 SC...Ca...Ca..Ca
16484 ! the conventional case
16485         sint=dsin(theta(i))
16486         sint1=dsin(omicron(2,i-1))
16487         sing=dsin(tauangle(1,i))
16488         cost=dcos(theta(i))
16489         cost1=dcos(omicron(2,i-1))
16490         cosg=dcos(tauangle(1,i))
16491 !elwrite(iout,*) " vecpr5",i,nres
16492         do j=1,3
16493 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16494 !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16495         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16496 !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16497         enddo
16498         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16499         fac0=1.0d0/(sint1*sint)
16500         fac1=cost*fac0
16501         fac2=cost1*fac0
16502         fac3=cosg*cost1/(sint1*sint1)
16503         fac4=cosg*cost/(sint*sint)
16504 !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16505 !    Obtaining the gamma derivatives from sine derivative
16506        if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16507            tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16508            tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16509          call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16510          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16511          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16512         do j=1,3
16513             ctgt=cost/sint
16514             ctgt1=cost1/sint1
16515             cosg_inv=1.0d0/cosg
16516             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16517        -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16518        *vbld_inv(i-2+nres)
16519             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16520             dsintau(j,1,2,i)= &
16521               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16522               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16523 !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16524             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16525 ! Bug fixed 3/24/05 (AL)
16526             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16527               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16528 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16529             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16530          enddo
16531 !   Obtaining the gamma derivatives from cosine derivative
16532         else
16533            do j=1,3
16534            dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16535            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16536            (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16537            dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16538            dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16539            dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16540            dcostheta(j,1,i)
16541            dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16542            dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16543            dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16544            dc_norm(j,i-1))/vbld(i)
16545            dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16546 !         write (iout,*) "else",i
16547          enddo
16548         endif
16549 !        do k=1,3
16550 !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16551 !        enddo
16552       enddo
16553 !C Second case Ca...Ca...Ca...SC
16554 #ifdef PARINTDER
16555       do i=itau_start,itau_end
16556 #else
16557       do i=4,nres
16558 #endif
16559        if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16560           (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16561 ! the conventional case
16562         sint=dsin(omicron(1,i))
16563         sint1=dsin(theta(i-1))
16564         sing=dsin(tauangle(2,i))
16565         cost=dcos(omicron(1,i))
16566         cost1=dcos(theta(i-1))
16567         cosg=dcos(tauangle(2,i))
16568 !        do j=1,3
16569 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16570 !        enddo
16571         scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16572         fac0=1.0d0/(sint1*sint)
16573         fac1=cost*fac0
16574         fac2=cost1*fac0
16575         fac3=cosg*cost1/(sint1*sint1)
16576         fac4=cosg*cost/(sint*sint)
16577 !    Obtaining the gamma derivatives from sine derivative
16578        if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16579            tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16580            tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16581          call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16582          call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16583          call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16584         do j=1,3
16585             ctgt=cost/sint
16586             ctgt1=cost1/sint1
16587             cosg_inv=1.0d0/cosg
16588             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16589               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16590 !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16591 !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16592             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16593             dsintau(j,2,2,i)= &
16594               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16595               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16596 !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16597 !     & sing*ctgt*domicron(j,1,2,i),
16598 !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16599             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16600 ! Bug fixed 3/24/05 (AL)
16601             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16602              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16603 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16604             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16605          enddo
16606 !   Obtaining the gamma derivatives from cosine derivative
16607         else
16608            do j=1,3
16609            dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16610            dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16611            dc_norm(j,i-3))/vbld(i-2)
16612            dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16613            dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16614            dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16615            dcosomicron(j,1,1,i)
16616            dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16617            dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16618            dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16619            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16620            dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16621 !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16622          enddo
16623         endif
16624       enddo
16625
16626 !CC third case SC...Ca...Ca...SC
16627 #ifdef PARINTDER
16628
16629       do i=itau_start,itau_end
16630 #else
16631       do i=3,nres
16632 #endif
16633 ! the conventional case
16634       if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16635       (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16636         sint=dsin(omicron(1,i))
16637         sint1=dsin(omicron(2,i-1))
16638         sing=dsin(tauangle(3,i))
16639         cost=dcos(omicron(1,i))
16640         cost1=dcos(omicron(2,i-1))
16641         cosg=dcos(tauangle(3,i))
16642         do j=1,3
16643         dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16644 !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16645         enddo
16646         scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16647         fac0=1.0d0/(sint1*sint)
16648         fac1=cost*fac0
16649         fac2=cost1*fac0
16650         fac3=cosg*cost1/(sint1*sint1)
16651         fac4=cosg*cost/(sint*sint)
16652 !    Obtaining the gamma derivatives from sine derivative
16653        if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16654            tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16655            tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16656          call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16657          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16658          call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16659         do j=1,3
16660             ctgt=cost/sint
16661             ctgt1=cost1/sint1
16662             cosg_inv=1.0d0/cosg
16663             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16664               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16665               *vbld_inv(i-2+nres)
16666             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16667             dsintau(j,3,2,i)= &
16668               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16669               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16670             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16671 ! Bug fixed 3/24/05 (AL)
16672             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16673               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16674               *vbld_inv(i-1+nres)
16675 !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16676             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16677          enddo
16678 !   Obtaining the gamma derivatives from cosine derivative
16679         else
16680            do j=1,3
16681            dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16682            dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16683            dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16684            dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16685            dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16686            dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16687            dcosomicron(j,1,1,i)
16688            dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16689            dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16690            dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16691            dc_norm(j,i-1+nres))/vbld(i-1+nres)
16692            dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16693 !          write(iout,*) "else",i
16694          enddo
16695         endif
16696       enddo
16697
16698 #ifdef CRYST_SC
16699 !   Derivatives of side-chain angles alpha and omega
16700 #if defined(MPI) && defined(PARINTDER)
16701         do i=ibond_start,ibond_end
16702 #else
16703         do i=2,nres-1
16704 #endif
16705           if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16706              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16707              fac6=fac5/vbld(i)
16708              fac7=fac5*fac5
16709              fac8=fac5/vbld(i+1)
16710              fac9=fac5/vbld(i+nres)
16711              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16712              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16713              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16714              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16715              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16716              sina=sqrt(1-cosa*cosa)
16717              sino=dsin(omeg(i))
16718 !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16719              do j=1,3
16720                 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16721                 dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16722                 dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16723                 dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16724                 scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16725                 dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16726                 dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16727                 dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16728                 vbld(i+nres))
16729                 dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16730             enddo
16731 ! obtaining the derivatives of omega from sines
16732             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16733                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16734                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16735                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16736                dsin(theta(i+1)))
16737                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16738                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16739                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16740                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16741                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16742                coso_inv=1.0d0/dcos(omeg(i))
16743                do j=1,3
16744                  dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16745                  +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16746                  (sino*dc_norm(j,i-1))/vbld(i)
16747                  domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16748                  dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16749                  +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16750                  -sino*dc_norm(j,i)/vbld(i+1)
16751                  domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16752                  dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16753                  fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16754                  vbld(i+nres)
16755                  domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16756               enddo
16757            else
16758 !   obtaining the derivatives of omega from cosines
16759              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16760              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16761              fac12=fac10*sina
16762              fac13=fac12*fac12
16763              fac14=sina*sina
16764              do j=1,3
16765                 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16766                 dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16767                 (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16768                 fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16769                 domega(j,1,i)=-1/sino*dcosomega(j,1,i)
16770                 dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
16771                 dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
16772                 dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
16773                 (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
16774                 dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
16775                 domega(j,2,i)=-1/sino*dcosomega(j,2,i)
16776                 dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
16777                 scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
16778                 (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
16779                 domega(j,3,i)=-1/sino*dcosomega(j,3,i)
16780             enddo
16781           endif
16782          else
16783            do j=1,3
16784              do k=1,3
16785                dalpha(k,j,i)=0.0d0
16786                domega(k,j,i)=0.0d0
16787              enddo
16788            enddo
16789          endif
16790        enddo
16791 #endif
16792 #if defined(MPI) && defined(PARINTDER)
16793       if (nfgtasks.gt.1) then
16794 #ifdef DEBUG
16795 !d      write (iout,*) "Gather dtheta"
16796 !d      call flush(iout)
16797       write (iout,*) "dtheta before gather"
16798       do i=1,nres
16799         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
16800       enddo
16801 #endif
16802       call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
16803         MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
16804         king,FG_COMM,IERROR)
16805 #ifdef DEBUG
16806 !d      write (iout,*) "Gather dphi"
16807 !d      call flush(iout)
16808       write (iout,*) "dphi before gather"
16809       do i=1,nres
16810         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
16811       enddo
16812 #endif
16813       call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
16814         MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
16815         king,FG_COMM,IERROR)
16816 !d      write (iout,*) "Gather dalpha"
16817 !d      call flush(iout)
16818 #ifdef CRYST_SC
16819       call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
16820         MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16821         king,FG_COMM,IERROR)
16822 !d      write (iout,*) "Gather domega"
16823 !d      call flush(iout)
16824       call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
16825         MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
16826         king,FG_COMM,IERROR)
16827 #endif
16828       endif
16829 #endif
16830 #ifdef DEBUG
16831       write (iout,*) "dtheta after gather"
16832       do i=1,nres
16833         write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
16834       enddo
16835       write (iout,*) "dphi after gather"
16836       do i=1,nres
16837         write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
16838       enddo
16839       write (iout,*) "dalpha after gather"
16840       do i=1,nres
16841         write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
16842       enddo
16843       write (iout,*) "domega after gather"
16844       do i=1,nres
16845         write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
16846       enddo
16847 #endif
16848       return
16849       end subroutine intcartderiv
16850 !-----------------------------------------------------------------------------
16851       subroutine checkintcartgrad
16852 !      implicit real*8 (a-h,o-z)
16853 !      include 'DIMENSIONS'
16854 #ifdef MPI
16855       include 'mpif.h'
16856 #endif
16857 !      include 'COMMON.CHAIN'
16858 !      include 'COMMON.VAR'
16859 !      include 'COMMON.GEO'
16860 !      include 'COMMON.INTERACT'
16861 !      include 'COMMON.DERIV'
16862 !      include 'COMMON.IOUNITS'
16863 !      include 'COMMON.SETUP'
16864       real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
16865       real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
16866       real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
16867       real(kind=8),dimension(3) :: dc_norm_s
16868       real(kind=8) :: aincr=1.0d-5
16869       integer :: i,j
16870       real(kind=8) :: dcji
16871       do i=1,nres
16872         phi_s(i)=phi(i)
16873         theta_s(i)=theta(i)
16874         alph_s(i)=alph(i)
16875         omeg_s(i)=omeg(i)
16876       enddo
16877 ! Check theta gradient
16878       write (iout,*) &
16879        "Analytical (upper) and numerical (lower) gradient of theta"
16880       write (iout,*)
16881       do i=3,nres
16882         do j=1,3
16883           dcji=dc(j,i-2)
16884           dc(j,i-2)=dcji+aincr
16885           call chainbuild_cart
16886           call int_from_cart1(.false.)
16887           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
16888           dc(j,i-2)=dcji
16889           dcji=dc(j,i-1)
16890           dc(j,i-1)=dc(j,i-1)+aincr
16891           call chainbuild_cart
16892           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
16893           dc(j,i-1)=dcji
16894         enddo
16895 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
16896 !el          (dtheta(j,2,i),j=1,3)
16897 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
16898 !el          (dthetanum(j,2,i),j=1,3)
16899 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
16900 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
16901 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
16902 !el        write (iout,*)
16903       enddo
16904 ! Check gamma gradient
16905       write (iout,*) &
16906        "Analytical (upper) and numerical (lower) gradient of gamma"
16907       do i=4,nres
16908         do j=1,3
16909           dcji=dc(j,i-3)
16910           dc(j,i-3)=dcji+aincr
16911           call chainbuild_cart
16912           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
16913           dc(j,i-3)=dcji
16914           dcji=dc(j,i-2)
16915           dc(j,i-2)=dcji+aincr
16916           call chainbuild_cart
16917           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
16918           dc(j,i-2)=dcji
16919           dcji=dc(j,i-1)
16920           dc(j,i-1)=dc(j,i-1)+aincr
16921           call chainbuild_cart
16922           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
16923           dc(j,i-1)=dcji
16924         enddo
16925 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
16926 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
16927 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
16928 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
16929 !el        write (iout,'(5x,3(3f10.5,5x))') &
16930 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
16931 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
16932 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
16933 !el        write (iout,*)
16934       enddo
16935 ! Check alpha gradient
16936       write (iout,*) &
16937        "Analytical (upper) and numerical (lower) gradient of alpha"
16938       do i=2,nres-1
16939        if(itype(i,1).ne.10) then
16940             do j=1,3
16941               dcji=dc(j,i-1)
16942               dc(j,i-1)=dcji+aincr
16943               call chainbuild_cart
16944               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
16945               /aincr
16946               dc(j,i-1)=dcji
16947               dcji=dc(j,i)
16948               dc(j,i)=dcji+aincr
16949               call chainbuild_cart
16950               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
16951               /aincr
16952               dc(j,i)=dcji
16953               dcji=dc(j,i+nres)
16954               dc(j,i+nres)=dc(j,i+nres)+aincr
16955               call chainbuild_cart
16956               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
16957               /aincr
16958              dc(j,i+nres)=dcji
16959             enddo
16960           endif
16961 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
16962 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
16963 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
16964 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
16965 !el        write (iout,'(5x,3(3f10.5,5x))') &
16966 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
16967 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
16968 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
16969 !el        write (iout,*)
16970       enddo
16971 !     Check omega gradient
16972       write (iout,*) &
16973        "Analytical (upper) and numerical (lower) gradient of omega"
16974       do i=2,nres-1
16975        if(itype(i,1).ne.10) then
16976             do j=1,3
16977               dcji=dc(j,i-1)
16978               dc(j,i-1)=dcji+aincr
16979               call chainbuild_cart
16980               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
16981               /aincr
16982               dc(j,i-1)=dcji
16983               dcji=dc(j,i)
16984               dc(j,i)=dcji+aincr
16985               call chainbuild_cart
16986               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
16987               /aincr
16988               dc(j,i)=dcji
16989               dcji=dc(j,i+nres)
16990               dc(j,i+nres)=dc(j,i+nres)+aincr
16991               call chainbuild_cart
16992               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
16993               /aincr
16994              dc(j,i+nres)=dcji
16995             enddo
16996           endif
16997 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
16998 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
16999 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17000 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17001 !el        write (iout,'(5x,3(3f10.5,5x))') &
17002 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17003 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17004 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17005 !el        write (iout,*)
17006       enddo
17007       return
17008       end subroutine checkintcartgrad
17009 !-----------------------------------------------------------------------------
17010 ! q_measure.F
17011 !-----------------------------------------------------------------------------
17012       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17013 !      implicit real*8 (a-h,o-z)
17014 !      include 'DIMENSIONS'
17015 !      include 'COMMON.IOUNITS'
17016 !      include 'COMMON.CHAIN'
17017 !      include 'COMMON.INTERACT'
17018 !      include 'COMMON.VAR'
17019       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17020       integer :: kkk,nsep=3
17021       real(kind=8) :: qm        !dist,
17022       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17023       logical :: lprn=.false.
17024       logical :: flag
17025 !      real(kind=8) :: sigm,x
17026
17027 !el      sigm(x)=0.25d0*x     ! local function
17028       qqmax=1.0d10
17029       do kkk=1,nperm
17030       qq = 0.0d0
17031       nl=0
17032        if(flag) then
17033         do il=seg1+nsep,seg2
17034           do jl=seg1,il-nsep
17035             nl=nl+1
17036             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17037                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17038                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17039             dij=dist(il,jl)
17040             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17041             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17042               nl=nl+1
17043               d0ijCM=dsqrt( &
17044                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17045                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17046                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17047               dijCM=dist(il+nres,jl+nres)
17048               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17049             endif
17050             qq = qq+qqij+qqijCM
17051           enddo
17052         enddo
17053         qq = qq/nl
17054       else
17055       do il=seg1,seg2
17056         if((seg3-il).lt.3) then
17057              secseg=il+3
17058         else
17059              secseg=seg3
17060         endif
17061           do jl=secseg,seg4
17062             nl=nl+1
17063             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17064                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17065                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17066             dij=dist(il,jl)
17067             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17068             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17069               nl=nl+1
17070               d0ijCM=dsqrt( &
17071                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17072                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17073                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17074               dijCM=dist(il+nres,jl+nres)
17075               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17076             endif
17077             qq = qq+qqij+qqijCM
17078           enddo
17079         enddo
17080       qq = qq/nl
17081       endif
17082       if (qqmax.le.qq) qqmax=qq
17083       enddo
17084       qwolynes=1.0d0-qqmax
17085       return
17086       end function qwolynes
17087 !-----------------------------------------------------------------------------
17088       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17089 !      implicit real*8 (a-h,o-z)
17090 !      include 'DIMENSIONS'
17091 !      include 'COMMON.IOUNITS'
17092 !      include 'COMMON.CHAIN'
17093 !      include 'COMMON.INTERACT'
17094 !      include 'COMMON.VAR'
17095 !      include 'COMMON.MD'
17096       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17097       integer :: nsep=3, kkk
17098 !el      real(kind=8) :: dist
17099       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17100       logical :: lprn=.false.
17101       logical :: flag
17102       real(kind=8) :: sim,dd0,fac,ddqij
17103 !el      sigm(x)=0.25d0*x            ! local function
17104       do kkk=1,nperm
17105       do i=0,nres
17106         do j=1,3
17107           dqwol(j,i)=0.0d0
17108           dxqwol(j,i)=0.0d0
17109         enddo
17110       enddo
17111       nl=0
17112        if(flag) then
17113         do il=seg1+nsep,seg2
17114           do jl=seg1,il-nsep
17115             nl=nl+1
17116             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17117                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17118                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17119             dij=dist(il,jl)
17120             sim = 1.0d0/sigm(d0ij)
17121             sim = sim*sim
17122             dd0 = dij-d0ij
17123             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17124             do k=1,3
17125               ddqij = (c(k,il)-c(k,jl))*fac
17126               dqwol(k,il)=dqwol(k,il)+ddqij
17127               dqwol(k,jl)=dqwol(k,jl)-ddqij
17128             enddo
17129
17130             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17131               nl=nl+1
17132               d0ijCM=dsqrt( &
17133                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17134                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17135                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17136               dijCM=dist(il+nres,jl+nres)
17137               sim = 1.0d0/sigm(d0ijCM)
17138               sim = sim*sim
17139               dd0=dijCM-d0ijCM
17140               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17141               do k=1,3
17142                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17143                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17144                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17145               enddo
17146             endif
17147           enddo
17148         enddo
17149        else
17150         do il=seg1,seg2
17151         if((seg3-il).lt.3) then
17152              secseg=il+3
17153         else
17154              secseg=seg3
17155         endif
17156           do jl=secseg,seg4
17157             nl=nl+1
17158             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17159                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17160                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17161             dij=dist(il,jl)
17162             sim = 1.0d0/sigm(d0ij)
17163             sim = sim*sim
17164             dd0 = dij-d0ij
17165             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17166             do k=1,3
17167               ddqij = (c(k,il)-c(k,jl))*fac
17168               dqwol(k,il)=dqwol(k,il)+ddqij
17169               dqwol(k,jl)=dqwol(k,jl)-ddqij
17170             enddo
17171             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17172               nl=nl+1
17173               d0ijCM=dsqrt( &
17174                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17175                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17176                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17177               dijCM=dist(il+nres,jl+nres)
17178               sim = 1.0d0/sigm(d0ijCM)
17179               sim=sim*sim
17180               dd0 = dijCM-d0ijCM
17181               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17182               do k=1,3
17183                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17184                dxqwol(k,il)=dxqwol(k,il)+ddqij
17185                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17186               enddo
17187             endif
17188           enddo
17189         enddo
17190       endif
17191       enddo
17192        do i=0,nres
17193          do j=1,3
17194            dqwol(j,i)=dqwol(j,i)/nl
17195            dxqwol(j,i)=dxqwol(j,i)/nl
17196          enddo
17197        enddo
17198       return
17199       end subroutine qwolynes_prim
17200 !-----------------------------------------------------------------------------
17201       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17202 !      implicit real*8 (a-h,o-z)
17203 !      include 'DIMENSIONS'
17204 !      include 'COMMON.IOUNITS'
17205 !      include 'COMMON.CHAIN'
17206 !      include 'COMMON.INTERACT'
17207 !      include 'COMMON.VAR'
17208       integer :: seg1,seg2,seg3,seg4
17209       logical :: flag
17210       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17211       real(kind=8),dimension(3,0:2*nres) :: cdummy
17212       real(kind=8) :: q1,q2
17213       real(kind=8) :: delta=1.0d-10
17214       integer :: i,j
17215
17216       do i=0,nres
17217         do j=1,3
17218           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17219           cdummy(j,i)=c(j,i)
17220           c(j,i)=c(j,i)+delta
17221           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17222           qwolan(j,i)=(q2-q1)/delta
17223           c(j,i)=cdummy(j,i)
17224         enddo
17225       enddo
17226       do i=0,nres
17227         do j=1,3
17228           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17229           cdummy(j,i+nres)=c(j,i+nres)
17230           c(j,i+nres)=c(j,i+nres)+delta
17231           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17232           qwolxan(j,i)=(q2-q1)/delta
17233           c(j,i+nres)=cdummy(j,i+nres)
17234         enddo
17235       enddo
17236 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17237 !      do i=0,nct
17238 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17239 !      enddo
17240 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17241 !      do i=0,nct
17242 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17243 !      enddo
17244       return
17245       end subroutine qwol_num
17246 !-----------------------------------------------------------------------------
17247       subroutine EconstrQ
17248 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17249 !      implicit real*8 (a-h,o-z)
17250 !      include 'DIMENSIONS'
17251 !      include 'COMMON.CONTROL'
17252 !      include 'COMMON.VAR'
17253 !      include 'COMMON.MD'
17254       use MD_data
17255 !#ifndef LANG0
17256 !      include 'COMMON.LANGEVIN'
17257 !#else
17258 !      include 'COMMON.LANGEVIN.lang0'
17259 !#endif
17260 !      include 'COMMON.CHAIN'
17261 !      include 'COMMON.DERIV'
17262 !      include 'COMMON.GEO'
17263 !      include 'COMMON.LOCAL'
17264 !      include 'COMMON.INTERACT'
17265 !      include 'COMMON.IOUNITS'
17266 !      include 'COMMON.NAMES'
17267 !      include 'COMMON.TIME1'
17268       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17269       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17270                    duconst,duxconst
17271       integer :: kstart,kend,lstart,lend,idummy
17272       real(kind=8) :: delta=1.0d-7
17273       integer :: i,j,k,ii
17274       do i=0,nres
17275          do j=1,3
17276             duconst(j,i)=0.0d0
17277             dudconst(j,i)=0.0d0
17278             duxconst(j,i)=0.0d0
17279             dudxconst(j,i)=0.0d0
17280          enddo
17281       enddo
17282       Uconst=0.0d0
17283       do i=1,nfrag
17284          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17285            idummy,idummy)
17286          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17287 ! Calculating the derivatives of Constraint energy with respect to Q
17288          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17289            qinfrag(i,iset))
17290 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17291 !        hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17292 !         hmnum=(hm2-hm1)/delta
17293 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17294 !     &   qinfrag(i,iset))
17295 !         write(iout,*) "harmonicnum frag", hmnum
17296 ! Calculating the derivatives of Q with respect to cartesian coordinates
17297          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17298           idummy,idummy)
17299 !         write(iout,*) "dqwol "
17300 !         do ii=1,nres
17301 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17302 !         enddo
17303 !         write(iout,*) "dxqwol "
17304 !         do ii=1,nres
17305 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17306 !         enddo
17307 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17308 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17309 !     &  ,idummy,idummy)
17310 !  The gradients of Uconst in Cs
17311          do ii=0,nres
17312             do j=1,3
17313                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17314                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17315             enddo
17316          enddo
17317       enddo
17318       do i=1,npair
17319          kstart=ifrag(1,ipair(1,i,iset),iset)
17320          kend=ifrag(2,ipair(1,i,iset),iset)
17321          lstart=ifrag(1,ipair(2,i,iset),iset)
17322          lend=ifrag(2,ipair(2,i,iset),iset)
17323          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17324          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17325 !  Calculating dU/dQ
17326          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17327 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17328 !        hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17329 !         hmnum=(hm2-hm1)/delta
17330 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17331 !     &   qinpair(i,iset))
17332 !         write(iout,*) "harmonicnum pair ", hmnum
17333 ! Calculating dQ/dXi
17334          call qwolynes_prim(kstart,kend,.false.,&
17335           lstart,lend)
17336 !         write(iout,*) "dqwol "
17337 !         do ii=1,nres
17338 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17339 !         enddo
17340 !         write(iout,*) "dxqwol "
17341 !         do ii=1,nres
17342 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17343 !        enddo
17344 ! Calculating numerical gradients
17345 !        call qwol_num(kstart,kend,.false.
17346 !     &  ,lstart,lend)
17347 ! The gradients of Uconst in Cs
17348          do ii=0,nres
17349             do j=1,3
17350                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17351                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17352             enddo
17353          enddo
17354       enddo
17355 !      write(iout,*) "Uconst inside subroutine ", Uconst
17356 ! Transforming the gradients from Cs to dCs for the backbone
17357       do i=0,nres
17358          do j=i+1,nres
17359            do k=1,3
17360              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17361            enddo
17362          enddo
17363       enddo
17364 !  Transforming the gradients from Cs to dCs for the side chains
17365       do i=1,nres
17366          do j=1,3
17367            dudxconst(j,i)=duxconst(j,i)
17368          enddo
17369       enddo
17370 !      write(iout,*) "dU/ddc backbone "
17371 !       do ii=0,nres
17372 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17373 !      enddo
17374 !      write(iout,*) "dU/ddX side chain "
17375 !      do ii=1,nres
17376 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17377 !      enddo
17378 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17379 !      call dEconstrQ_num
17380       return
17381       end subroutine EconstrQ
17382 !-----------------------------------------------------------------------------
17383       subroutine dEconstrQ_num
17384 ! Calculating numerical dUconst/ddc and dUconst/ddx
17385 !      implicit real*8 (a-h,o-z)
17386 !      include 'DIMENSIONS'
17387 !      include 'COMMON.CONTROL'
17388 !      include 'COMMON.VAR'
17389 !      include 'COMMON.MD'
17390       use MD_data
17391 !#ifndef LANG0
17392 !      include 'COMMON.LANGEVIN'
17393 !#else
17394 !      include 'COMMON.LANGEVIN.lang0'
17395 !#endif
17396 !      include 'COMMON.CHAIN'
17397 !      include 'COMMON.DERIV'
17398 !      include 'COMMON.GEO'
17399 !      include 'COMMON.LOCAL'
17400 !      include 'COMMON.INTERACT'
17401 !      include 'COMMON.IOUNITS'
17402 !      include 'COMMON.NAMES'
17403 !      include 'COMMON.TIME1'
17404       real(kind=8) :: uzap1,uzap2
17405       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17406       integer :: kstart,kend,lstart,lend,idummy
17407       real(kind=8) :: delta=1.0d-7
17408 !el local variables
17409       integer :: i,ii,j
17410 !     real(kind=8) ::
17411 !     For the backbone
17412       do i=0,nres-1
17413          do j=1,3
17414             dUcartan(j,i)=0.0d0
17415             cdummy(j,i)=dc(j,i)
17416             dc(j,i)=dc(j,i)+delta
17417             call chainbuild_cart
17418             uzap2=0.0d0
17419             do ii=1,nfrag
17420              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17421                 idummy,idummy)
17422                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17423                 qinfrag(ii,iset))
17424             enddo
17425             do ii=1,npair
17426                kstart=ifrag(1,ipair(1,ii,iset),iset)
17427                kend=ifrag(2,ipair(1,ii,iset),iset)
17428                lstart=ifrag(1,ipair(2,ii,iset),iset)
17429                lend=ifrag(2,ipair(2,ii,iset),iset)
17430                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17431                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17432                  qinpair(ii,iset))
17433             enddo
17434             dc(j,i)=cdummy(j,i)
17435             call chainbuild_cart
17436             uzap1=0.0d0
17437              do ii=1,nfrag
17438              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17439                 idummy,idummy)
17440                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17441                 qinfrag(ii,iset))
17442             enddo
17443             do ii=1,npair
17444                kstart=ifrag(1,ipair(1,ii,iset),iset)
17445                kend=ifrag(2,ipair(1,ii,iset),iset)
17446                lstart=ifrag(1,ipair(2,ii,iset),iset)
17447                lend=ifrag(2,ipair(2,ii,iset),iset)
17448                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17449                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17450                 qinpair(ii,iset))
17451             enddo
17452             ducartan(j,i)=(uzap2-uzap1)/(delta)
17453          enddo
17454       enddo
17455 ! Calculating numerical gradients for dU/ddx
17456       do i=0,nres-1
17457          duxcartan(j,i)=0.0d0
17458          do j=1,3
17459             cdummy(j,i)=dc(j,i+nres)
17460             dc(j,i+nres)=dc(j,i+nres)+delta
17461             call chainbuild_cart
17462             uzap2=0.0d0
17463             do ii=1,nfrag
17464              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17465                 idummy,idummy)
17466                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17467                 qinfrag(ii,iset))
17468             enddo
17469             do ii=1,npair
17470                kstart=ifrag(1,ipair(1,ii,iset),iset)
17471                kend=ifrag(2,ipair(1,ii,iset),iset)
17472                lstart=ifrag(1,ipair(2,ii,iset),iset)
17473                lend=ifrag(2,ipair(2,ii,iset),iset)
17474                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17475                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17476                 qinpair(ii,iset))
17477             enddo
17478             dc(j,i+nres)=cdummy(j,i)
17479             call chainbuild_cart
17480             uzap1=0.0d0
17481              do ii=1,nfrag
17482                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17483                 ifrag(2,ii,iset),.true.,idummy,idummy)
17484                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17485                 qinfrag(ii,iset))
17486             enddo
17487             do ii=1,npair
17488                kstart=ifrag(1,ipair(1,ii,iset),iset)
17489                kend=ifrag(2,ipair(1,ii,iset),iset)
17490                lstart=ifrag(1,ipair(2,ii,iset),iset)
17491                lend=ifrag(2,ipair(2,ii,iset),iset)
17492                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17493                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17494                 qinpair(ii,iset))
17495             enddo
17496             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17497          enddo
17498       enddo
17499       write(iout,*) "Numerical dUconst/ddc backbone "
17500       do ii=0,nres
17501         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17502       enddo
17503 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17504 !      do ii=1,nres
17505 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17506 !      enddo
17507       return
17508       end subroutine dEconstrQ_num
17509 !-----------------------------------------------------------------------------
17510 ! ssMD.F
17511 !-----------------------------------------------------------------------------
17512       subroutine check_energies
17513
17514 !      use random, only: ran_number
17515
17516 !      implicit none
17517 !     Includes
17518 !      include 'DIMENSIONS'
17519 !      include 'COMMON.CHAIN'
17520 !      include 'COMMON.VAR'
17521 !      include 'COMMON.IOUNITS'
17522 !      include 'COMMON.SBRIDGE'
17523 !      include 'COMMON.LOCAL'
17524 !      include 'COMMON.GEO'
17525
17526 !     External functions
17527 !EL      double precision ran_number
17528 !EL      external ran_number
17529
17530 !     Local variables
17531       integer :: i,j,k,l,lmax,p,pmax
17532       real(kind=8) :: rmin,rmax
17533       real(kind=8) :: eij
17534
17535       real(kind=8) :: d
17536       real(kind=8) :: wi,rij,tj,pj
17537 !      return
17538
17539       i=5
17540       j=14
17541
17542       d=dsc(1)
17543       rmin=2.0D0
17544       rmax=12.0D0
17545
17546       lmax=10000
17547       pmax=1
17548
17549       do k=1,3
17550         c(k,i)=0.0D0
17551         c(k,j)=0.0D0
17552         c(k,nres+i)=0.0D0
17553         c(k,nres+j)=0.0D0
17554       enddo
17555
17556       do l=1,lmax
17557
17558 !t        wi=ran_number(0.0D0,pi)
17559 !        wi=ran_number(0.0D0,pi/6.0D0)
17560 !        wi=0.0D0
17561 !t        tj=ran_number(0.0D0,pi)
17562 !t        pj=ran_number(0.0D0,pi)
17563 !        pj=ran_number(0.0D0,pi/6.0D0)
17564 !        pj=0.0D0
17565
17566         do p=1,pmax
17567 !t           rij=ran_number(rmin,rmax)
17568
17569            c(1,j)=d*sin(pj)*cos(tj)
17570            c(2,j)=d*sin(pj)*sin(tj)
17571            c(3,j)=d*cos(pj)
17572
17573            c(3,nres+i)=-rij
17574
17575            c(1,i)=d*sin(wi)
17576            c(3,i)=-rij-d*cos(wi)
17577
17578            do k=1,3
17579               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17580               dc_norm(k,nres+i)=dc(k,nres+i)/d
17581               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17582               dc_norm(k,nres+j)=dc(k,nres+j)/d
17583            enddo
17584
17585            call dyn_ssbond_ene(i,j,eij)
17586         enddo
17587       enddo
17588       call exit(1)
17589       return
17590       end subroutine check_energies
17591 !-----------------------------------------------------------------------------
17592       subroutine dyn_ssbond_ene(resi,resj,eij)
17593 !      implicit none
17594 !      Includes
17595       use calc_data
17596       use comm_sschecks
17597 !      include 'DIMENSIONS'
17598 !      include 'COMMON.SBRIDGE'
17599 !      include 'COMMON.CHAIN'
17600 !      include 'COMMON.DERIV'
17601 !      include 'COMMON.LOCAL'
17602 !      include 'COMMON.INTERACT'
17603 !      include 'COMMON.VAR'
17604 !      include 'COMMON.IOUNITS'
17605 !      include 'COMMON.CALC'
17606 #ifndef CLUST
17607 #ifndef WHAM
17608        use MD_data
17609 !      include 'COMMON.MD'
17610 !      use MD, only: totT,t_bath
17611 #endif
17612 #endif
17613 !     External functions
17614 !EL      double precision h_base
17615 !EL      external h_base
17616
17617 !     Input arguments
17618       integer :: resi,resj
17619
17620 !     Output arguments
17621       real(kind=8) :: eij
17622
17623 !     Local variables
17624       logical :: havebond
17625       integer itypi,itypj
17626       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17627       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17628       real(kind=8),dimension(3) :: dcosom1,dcosom2
17629       real(kind=8) :: ed
17630       real(kind=8) :: pom1,pom2
17631       real(kind=8) :: ljA,ljB,ljXs
17632       real(kind=8),dimension(1:3) :: d_ljB
17633       real(kind=8) :: ssA,ssB,ssC,ssXs
17634       real(kind=8) :: ssxm,ljxm,ssm,ljm
17635       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17636       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17637       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17638 !-------FIRST METHOD
17639       real(kind=8) :: xm
17640       real(kind=8),dimension(1:3) :: d_xm
17641 !-------END FIRST METHOD
17642 !-------SECOND METHOD
17643 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17644 !-------END SECOND METHOD
17645
17646 !-------TESTING CODE
17647 !el      logical :: checkstop,transgrad
17648 !el      common /sschecks/ checkstop,transgrad
17649
17650       integer :: icheck,nicheck,jcheck,njcheck
17651       real(kind=8),dimension(-1:1) :: echeck
17652       real(kind=8) :: deps,ssx0,ljx0
17653 !-------END TESTING CODE
17654
17655       eij=0.0d0
17656       i=resi
17657       j=resj
17658
17659 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17660 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17661
17662       itypi=itype(i,1)
17663       dxi=dc_norm(1,nres+i)
17664       dyi=dc_norm(2,nres+i)
17665       dzi=dc_norm(3,nres+i)
17666       dsci_inv=vbld_inv(i+nres)
17667
17668       itypj=itype(j,1)
17669       xj=c(1,nres+j)-c(1,nres+i)
17670       yj=c(2,nres+j)-c(2,nres+i)
17671       zj=c(3,nres+j)-c(3,nres+i)
17672       dxj=dc_norm(1,nres+j)
17673       dyj=dc_norm(2,nres+j)
17674       dzj=dc_norm(3,nres+j)
17675       dscj_inv=vbld_inv(j+nres)
17676
17677       chi1=chi(itypi,itypj)
17678       chi2=chi(itypj,itypi)
17679       chi12=chi1*chi2
17680       chip1=chip(itypi)
17681       chip2=chip(itypj)
17682       chip12=chip1*chip2
17683       alf1=alp(itypi)
17684       alf2=alp(itypj)
17685       alf12=0.5D0*(alf1+alf2)
17686
17687       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17688       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17689 !     The following are set in sc_angular
17690 !      erij(1)=xj*rij
17691 !      erij(2)=yj*rij
17692 !      erij(3)=zj*rij
17693 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17694 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17695 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17696       call sc_angular
17697       rij=1.0D0/rij  ! Reset this so it makes sense
17698
17699       sig0ij=sigma(itypi,itypj)
17700       sig=sig0ij*dsqrt(1.0D0/sigsq)
17701
17702       ljXs=sig-sig0ij
17703       ljA=eps1*eps2rt**2*eps3rt**2
17704       ljB=ljA*bb_aq(itypi,itypj)
17705       ljA=ljA*aa_aq(itypi,itypj)
17706       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17707
17708       ssXs=d0cm
17709       deltat1=1.0d0-om1
17710       deltat2=1.0d0+om2
17711       deltat12=om2-om1+2.0d0
17712       cosphi=om12-om1*om2
17713       ssA=akcm
17714       ssB=akct*deltat12
17715       ssC=ss_depth &
17716            +akth*(deltat1*deltat1+deltat2*deltat2) &
17717            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17718       ssxm=ssXs-0.5D0*ssB/ssA
17719
17720 !-------TESTING CODE
17721 !$$$c     Some extra output
17722 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17723 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17724 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17725 !$$$      if (ssx0.gt.0.0d0) then
17726 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17727 !$$$      else
17728 !$$$        ssx0=ssxm
17729 !$$$      endif
17730 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17731 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17732 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17733 !$$$      return
17734 !-------END TESTING CODE
17735
17736 !-------TESTING CODE
17737 !     Stop and plot energy and derivative as a function of distance
17738       if (checkstop) then
17739         ssm=ssC-0.25D0*ssB*ssB/ssA
17740         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17741         if (ssm.lt.ljm .and. &
17742              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17743           nicheck=1000
17744           njcheck=1
17745           deps=0.5d-7
17746         else
17747           checkstop=.false.
17748         endif
17749       endif
17750       if (.not.checkstop) then
17751         nicheck=0
17752         njcheck=-1
17753       endif
17754
17755       do icheck=0,nicheck
17756       do jcheck=-1,njcheck
17757       if (checkstop) rij=(ssxm-1.0d0)+ &
17758              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17759 !-------END TESTING CODE
17760
17761       if (rij.gt.ljxm) then
17762         havebond=.false.
17763         ljd=rij-ljXs
17764         fac=(1.0D0/ljd)**expon
17765         e1=fac*fac*aa_aq(itypi,itypj)
17766         e2=fac*bb_aq(itypi,itypj)
17767         eij=eps1*eps2rt*eps3rt*(e1+e2)
17768         eps2der=eij*eps3rt
17769         eps3der=eij*eps2rt
17770         eij=eij*eps2rt*eps3rt
17771
17772         sigder=-sig/sigsq
17773         e1=e1*eps1*eps2rt**2*eps3rt**2
17774         ed=-expon*(e1+eij)/ljd
17775         sigder=ed*sigder
17776         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17777         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17778         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
17779              -2.0D0*alf12*eps3der+sigder*sigsq_om12
17780       else if (rij.lt.ssxm) then
17781         havebond=.true.
17782         ssd=rij-ssXs
17783         eij=ssA*ssd*ssd+ssB*ssd+ssC
17784
17785         ed=2*akcm*ssd+akct*deltat12
17786         pom1=akct*ssd
17787         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
17788         eom1=-2*akth*deltat1-pom1-om2*pom2
17789         eom2= 2*akth*deltat2+pom1-om1*pom2
17790         eom12=pom2
17791       else
17792         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
17793
17794         d_ssxm(1)=0.5D0*akct/ssA
17795         d_ssxm(2)=-d_ssxm(1)
17796         d_ssxm(3)=0.0D0
17797
17798         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
17799         d_ljxm(2)=d_ljxm(1)*sigsq_om2
17800         d_ljxm(3)=d_ljxm(1)*sigsq_om12
17801         d_ljxm(1)=d_ljxm(1)*sigsq_om1
17802
17803 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17804         xm=0.5d0*(ssxm+ljxm)
17805         do k=1,3
17806           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
17807         enddo
17808         if (rij.lt.xm) then
17809           havebond=.true.
17810           ssm=ssC-0.25D0*ssB*ssB/ssA
17811           d_ssm(1)=0.5D0*akct*ssB/ssA
17812           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17813           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17814           d_ssm(3)=omega
17815           f1=(rij-xm)/(ssxm-xm)
17816           f2=(rij-ssxm)/(xm-ssxm)
17817           h1=h_base(f1,hd1)
17818           h2=h_base(f2,hd2)
17819           eij=ssm*h1+Ht*h2
17820           delta_inv=1.0d0/(xm-ssxm)
17821           deltasq_inv=delta_inv*delta_inv
17822           fac=ssm*hd1-Ht*hd2
17823           fac1=deltasq_inv*fac*(xm-rij)
17824           fac2=deltasq_inv*fac*(rij-ssxm)
17825           ed=delta_inv*(Ht*hd2-ssm*hd1)
17826           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
17827           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
17828           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
17829         else
17830           havebond=.false.
17831           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17832           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
17833           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
17834           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
17835                alf12/eps3rt)
17836           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
17837           f1=(rij-ljxm)/(xm-ljxm)
17838           f2=(rij-xm)/(ljxm-xm)
17839           h1=h_base(f1,hd1)
17840           h2=h_base(f2,hd2)
17841           eij=Ht*h1+ljm*h2
17842           delta_inv=1.0d0/(ljxm-xm)
17843           deltasq_inv=delta_inv*delta_inv
17844           fac=Ht*hd1-ljm*hd2
17845           fac1=deltasq_inv*fac*(ljxm-rij)
17846           fac2=deltasq_inv*fac*(rij-xm)
17847           ed=delta_inv*(ljm*hd2-Ht*hd1)
17848           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
17849           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
17850           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
17851         endif
17852 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
17853
17854 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17855 !$$$        ssd=rij-ssXs
17856 !$$$        ljd=rij-ljXs
17857 !$$$        fac1=rij-ljxm
17858 !$$$        fac2=rij-ssxm
17859 !$$$
17860 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
17861 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
17862 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
17863 !$$$
17864 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
17865 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
17866 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
17867 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
17868 !$$$        d_ssm(3)=omega
17869 !$$$
17870 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
17871 !$$$        do k=1,3
17872 !$$$          d_ljm(k)=ljm*d_ljB(k)
17873 !$$$        enddo
17874 !$$$        ljm=ljm*ljB
17875 !$$$
17876 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
17877 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
17878 !$$$        d_ss(2)=akct*ssd
17879 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
17880 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
17881 !$$$        d_ss(3)=omega
17882 !$$$
17883 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
17884 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
17885 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
17886 !$$$        do k=1,3
17887 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
17888 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
17889 !$$$        enddo
17890 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
17891 !$$$
17892 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
17893 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
17894 !$$$        h1=h_base(f1,hd1)
17895 !$$$        h2=h_base(f2,hd2)
17896 !$$$        eij=ss*h1+ljf*h2
17897 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
17898 !$$$        deltasq_inv=delta_inv*delta_inv
17899 !$$$        fac=ljf*hd2-ss*hd1
17900 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
17901 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
17902 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
17903 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
17904 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
17905 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
17906 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
17907 !$$$
17908 !$$$        havebond=.false.
17909 !$$$        if (ed.gt.0.0d0) havebond=.true.
17910 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
17911
17912       endif
17913
17914       if (havebond) then
17915 !#ifndef CLUST
17916 !#ifndef WHAM
17917 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
17918 !          write(iout,'(a15,f12.2,f8.1,2i5)')
17919 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
17920 !        endif
17921 !#endif
17922 !#endif
17923         dyn_ssbond_ij(i,j)=eij
17924       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
17925         dyn_ssbond_ij(i,j)=1.0d300
17926 !#ifndef CLUST
17927 !#ifndef WHAM
17928 !        write(iout,'(a15,f12.2,f8.1,2i5)')
17929 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
17930 !#endif
17931 !#endif
17932       endif
17933
17934 !-------TESTING CODE
17935 !el      if (checkstop) then
17936         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
17937              "CHECKSTOP",rij,eij,ed
17938         echeck(jcheck)=eij
17939 !el      endif
17940       enddo
17941       if (checkstop) then
17942         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
17943       endif
17944       enddo
17945       if (checkstop) then
17946         transgrad=.true.
17947         checkstop=.false.
17948       endif
17949 !-------END TESTING CODE
17950
17951       do k=1,3
17952         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
17953         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
17954       enddo
17955       do k=1,3
17956         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
17957       enddo
17958       do k=1,3
17959         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
17960              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
17961              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
17962         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
17963              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
17964              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
17965       enddo
17966 !grad      do k=i,j-1
17967 !grad        do l=1,3
17968 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
17969 !grad        enddo
17970 !grad      enddo
17971
17972       do l=1,3
17973         gvdwc(l,i)=gvdwc(l,i)-gg(l)
17974         gvdwc(l,j)=gvdwc(l,j)+gg(l)
17975       enddo
17976
17977       return
17978       end subroutine dyn_ssbond_ene
17979 !--------------------------------------------------------------------------
17980          subroutine triple_ssbond_ene(resi,resj,resk,eij)
17981 !      implicit none
17982 !      Includes
17983       use calc_data
17984       use comm_sschecks
17985 !      include 'DIMENSIONS'
17986 !      include 'COMMON.SBRIDGE'
17987 !      include 'COMMON.CHAIN'
17988 !      include 'COMMON.DERIV'
17989 !      include 'COMMON.LOCAL'
17990 !      include 'COMMON.INTERACT'
17991 !      include 'COMMON.VAR'
17992 !      include 'COMMON.IOUNITS'
17993 !      include 'COMMON.CALC'
17994 #ifndef CLUST
17995 #ifndef WHAM
17996        use MD_data
17997 !      include 'COMMON.MD'
17998 !      use MD, only: totT,t_bath
17999 #endif
18000 #endif
18001       double precision h_base
18002       external h_base
18003
18004 !c     Input arguments
18005       integer resi,resj,resk,m,itypi,itypj,itypk
18006
18007 !c     Output arguments
18008       double precision eij,eij1,eij2,eij3
18009
18010 !c     Local variables
18011       logical havebond
18012 !c      integer itypi,itypj,k,l
18013       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18014       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18015       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18016       double precision sig0ij,ljd,sig,fac,e1,e2
18017       double precision dcosom1(3),dcosom2(3),ed
18018       double precision pom1,pom2
18019       double precision ljA,ljB,ljXs
18020       double precision d_ljB(1:3)
18021       double precision ssA,ssB,ssC,ssXs
18022       double precision ssxm,ljxm,ssm,ljm
18023       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18024       eij=0.0
18025       if (dtriss.eq.0) return
18026       i=resi
18027       j=resj
18028       k=resk
18029 !C      write(iout,*) resi,resj,resk
18030       itypi=itype(i,1)
18031       dxi=dc_norm(1,nres+i)
18032       dyi=dc_norm(2,nres+i)
18033       dzi=dc_norm(3,nres+i)
18034       dsci_inv=vbld_inv(i+nres)
18035       xi=c(1,nres+i)
18036       yi=c(2,nres+i)
18037       zi=c(3,nres+i)
18038       itypj=itype(j,1)
18039       xj=c(1,nres+j)
18040       yj=c(2,nres+j)
18041       zj=c(3,nres+j)
18042
18043       dxj=dc_norm(1,nres+j)
18044       dyj=dc_norm(2,nres+j)
18045       dzj=dc_norm(3,nres+j)
18046       dscj_inv=vbld_inv(j+nres)
18047       itypk=itype(k,1)
18048       xk=c(1,nres+k)
18049       yk=c(2,nres+k)
18050       zk=c(3,nres+k)
18051
18052       dxk=dc_norm(1,nres+k)
18053       dyk=dc_norm(2,nres+k)
18054       dzk=dc_norm(3,nres+k)
18055       dscj_inv=vbld_inv(k+nres)
18056       xij=xj-xi
18057       xik=xk-xi
18058       xjk=xk-xj
18059       yij=yj-yi
18060       yik=yk-yi
18061       yjk=yk-yj
18062       zij=zj-zi
18063       zik=zk-zi
18064       zjk=zk-zj
18065       rrij=(xij*xij+yij*yij+zij*zij)
18066       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18067       rrik=(xik*xik+yik*yik+zik*zik)
18068       rik=dsqrt(rrik)
18069       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18070       rjk=dsqrt(rrjk)
18071 !C there are three combination of distances for each trisulfide bonds
18072 !C The first case the ith atom is the center
18073 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18074 !C distance y is second distance the a,b,c,d are parameters derived for
18075 !C this problem d parameter was set as a penalty currenlty set to 1.
18076       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18077       eij1=0.0d0
18078       else
18079       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18080       endif
18081 !C second case jth atom is center
18082       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18083       eij2=0.0d0
18084       else
18085       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18086       endif
18087 !C the third case kth atom is the center
18088       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18089       eij3=0.0d0
18090       else
18091       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18092       endif
18093 !C      eij2=0.0
18094 !C      eij3=0.0
18095 !C      eij1=0.0
18096       eij=eij1+eij2+eij3
18097 !C      write(iout,*)i,j,k,eij
18098 !C The energy penalty calculated now time for the gradient part
18099 !C derivative over rij
18100       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18101       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18102             gg(1)=xij*fac/rij
18103             gg(2)=yij*fac/rij
18104             gg(3)=zij*fac/rij
18105       do m=1,3
18106         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18107         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18108       enddo
18109
18110       do l=1,3
18111         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18112         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18113       enddo
18114 !C now derivative over rik
18115       fac=-eij1**2/dtriss* &
18116       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18117       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18118             gg(1)=xik*fac/rik
18119             gg(2)=yik*fac/rik
18120             gg(3)=zik*fac/rik
18121       do m=1,3
18122         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18123         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18124       enddo
18125       do l=1,3
18126         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18127         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18128       enddo
18129 !C now derivative over rjk
18130       fac=-eij2**2/dtriss* &
18131       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18132       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18133             gg(1)=xjk*fac/rjk
18134             gg(2)=yjk*fac/rjk
18135             gg(3)=zjk*fac/rjk
18136       do m=1,3
18137         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18138         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18139       enddo
18140       do l=1,3
18141         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18142         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18143       enddo
18144       return
18145       end subroutine triple_ssbond_ene
18146
18147
18148
18149 !-----------------------------------------------------------------------------
18150       real(kind=8) function h_base(x,deriv)
18151 !     A smooth function going 0->1 in range [0,1]
18152 !     It should NOT be called outside range [0,1], it will not work there.
18153       implicit none
18154
18155 !     Input arguments
18156       real(kind=8) :: x
18157
18158 !     Output arguments
18159       real(kind=8) :: deriv
18160
18161 !     Local variables
18162       real(kind=8) :: xsq
18163
18164
18165 !     Two parabolas put together.  First derivative zero at extrema
18166 !$$$      if (x.lt.0.5D0) then
18167 !$$$        h_base=2.0D0*x*x
18168 !$$$        deriv=4.0D0*x
18169 !$$$      else
18170 !$$$        deriv=1.0D0-x
18171 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18172 !$$$        deriv=4.0D0*deriv
18173 !$$$      endif
18174
18175 !     Third degree polynomial.  First derivative zero at extrema
18176       h_base=x*x*(3.0d0-2.0d0*x)
18177       deriv=6.0d0*x*(1.0d0-x)
18178
18179 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18180 !$$$      xsq=x*x
18181 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18182 !$$$      deriv=x-1.0d0
18183 !$$$      deriv=deriv*deriv
18184 !$$$      deriv=30.0d0*xsq*deriv
18185
18186       return
18187       end function h_base
18188 !-----------------------------------------------------------------------------
18189       subroutine dyn_set_nss
18190 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18191 !      implicit none
18192       use MD_data, only: totT,t_bath
18193 !     Includes
18194 !      include 'DIMENSIONS'
18195 #ifdef MPI
18196       include "mpif.h"
18197 #endif
18198 !      include 'COMMON.SBRIDGE'
18199 !      include 'COMMON.CHAIN'
18200 !      include 'COMMON.IOUNITS'
18201 !      include 'COMMON.SETUP'
18202 !      include 'COMMON.MD'
18203 !     Local variables
18204       real(kind=8) :: emin
18205       integer :: i,j,imin,ierr
18206       integer :: diff,allnss,newnss
18207       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18208                 newihpb,newjhpb
18209       logical :: found
18210       integer,dimension(0:nfgtasks) :: i_newnss
18211       integer,dimension(0:nfgtasks) :: displ
18212       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18213       integer :: g_newnss
18214
18215       allnss=0
18216       do i=1,nres-1
18217         do j=i+1,nres
18218           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18219             allnss=allnss+1
18220             allflag(allnss)=0
18221             allihpb(allnss)=i
18222             alljhpb(allnss)=j
18223           endif
18224         enddo
18225       enddo
18226
18227 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18228
18229  1    emin=1.0d300
18230       do i=1,allnss
18231         if (allflag(i).eq.0 .and. &
18232              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18233           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18234           imin=i
18235         endif
18236       enddo
18237       if (emin.lt.1.0d300) then
18238         allflag(imin)=1
18239         do i=1,allnss
18240           if (allflag(i).eq.0 .and. &
18241                (allihpb(i).eq.allihpb(imin) .or. &
18242                alljhpb(i).eq.allihpb(imin) .or. &
18243                allihpb(i).eq.alljhpb(imin) .or. &
18244                alljhpb(i).eq.alljhpb(imin))) then
18245             allflag(i)=-1
18246           endif
18247         enddo
18248         goto 1
18249       endif
18250
18251 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18252
18253       newnss=0
18254       do i=1,allnss
18255         if (allflag(i).eq.1) then
18256           newnss=newnss+1
18257           newihpb(newnss)=allihpb(i)
18258           newjhpb(newnss)=alljhpb(i)
18259         endif
18260       enddo
18261
18262 #ifdef MPI
18263       if (nfgtasks.gt.1)then
18264
18265         call MPI_Reduce(newnss,g_newnss,1,&
18266           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18267         call MPI_Gather(newnss,1,MPI_INTEGER,&
18268                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18269         displ(0)=0
18270         do i=1,nfgtasks-1,1
18271           displ(i)=i_newnss(i-1)+displ(i-1)
18272         enddo
18273         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18274                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18275                          king,FG_COMM,IERR)
18276         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18277                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18278                          king,FG_COMM,IERR)
18279         if(fg_rank.eq.0) then
18280 !         print *,'g_newnss',g_newnss
18281 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18282 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18283          newnss=g_newnss
18284          do i=1,newnss
18285           newihpb(i)=g_newihpb(i)
18286           newjhpb(i)=g_newjhpb(i)
18287          enddo
18288         endif
18289       endif
18290 #endif
18291
18292       diff=newnss-nss
18293
18294 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18295 !       print *,newnss,nss,maxdim
18296       do i=1,nss
18297         found=.false.
18298 !        print *,newnss
18299         do j=1,newnss
18300 !!          print *,j
18301           if (idssb(i).eq.newihpb(j) .and. &
18302                jdssb(i).eq.newjhpb(j)) found=.true.
18303         enddo
18304 #ifndef CLUST
18305 #ifndef WHAM
18306 !        write(iout,*) "found",found,i,j
18307         if (.not.found.and.fg_rank.eq.0) &
18308             write(iout,'(a15,f12.2,f8.1,2i5)') &
18309              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18310 #endif
18311 #endif
18312       enddo
18313
18314       do i=1,newnss
18315         found=.false.
18316         do j=1,nss
18317 !          print *,i,j
18318           if (newihpb(i).eq.idssb(j) .and. &
18319                newjhpb(i).eq.jdssb(j)) found=.true.
18320         enddo
18321 #ifndef CLUST
18322 #ifndef WHAM
18323 !        write(iout,*) "found",found,i,j
18324         if (.not.found.and.fg_rank.eq.0) &
18325             write(iout,'(a15,f12.2,f8.1,2i5)') &
18326              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18327 #endif
18328 #endif
18329       enddo
18330
18331       nss=newnss
18332       do i=1,nss
18333         idssb(i)=newihpb(i)
18334         jdssb(i)=newjhpb(i)
18335       enddo
18336
18337       return
18338       end subroutine dyn_set_nss
18339 ! Lipid transfer energy function
18340       subroutine Eliptransfer(eliptran)
18341 !C this is done by Adasko
18342 !C      print *,"wchodze"
18343 !C structure of box:
18344 !C      water
18345 !C--bordliptop-- buffore starts
18346 !C--bufliptop--- here true lipid starts
18347 !C      lipid
18348 !C--buflipbot--- lipid ends buffore starts
18349 !C--bordlipbot--buffore ends
18350       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18351       integer :: i
18352       eliptran=0.0
18353 !      print *, "I am in eliptran"
18354       do i=ilip_start,ilip_end
18355 !C       do i=1,1
18356         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18357          cycle
18358
18359         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18360         if (positi.le.0.0) positi=positi+boxzsize
18361 !C        print *,i
18362 !C first for peptide groups
18363 !c for each residue check if it is in lipid or lipid water border area
18364        if ((positi.gt.bordlipbot)  &
18365       .and.(positi.lt.bordliptop)) then
18366 !C the energy transfer exist
18367         if (positi.lt.buflipbot) then
18368 !C what fraction I am in
18369          fracinbuf=1.0d0-      &
18370              ((positi-bordlipbot)/lipbufthick)
18371 !C lipbufthick is thickenes of lipid buffore
18372          sslip=sscalelip(fracinbuf)
18373          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18374          eliptran=eliptran+sslip*pepliptran
18375          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18376          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18377 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18378
18379 !C        print *,"doing sccale for lower part"
18380 !C         print *,i,sslip,fracinbuf,ssgradlip
18381         elseif (positi.gt.bufliptop) then
18382          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18383          sslip=sscalelip(fracinbuf)
18384          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18385          eliptran=eliptran+sslip*pepliptran
18386          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18387          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18388 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18389 !C          print *, "doing sscalefor top part"
18390 !C         print *,i,sslip,fracinbuf,ssgradlip
18391         else
18392          eliptran=eliptran+pepliptran
18393 !C         print *,"I am in true lipid"
18394         endif
18395 !C       else
18396 !C       eliptran=elpitran+0.0 ! I am in water
18397        endif
18398        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18399        enddo
18400 ! here starts the side chain transfer
18401        do i=ilip_start,ilip_end
18402         if (itype(i,1).eq.ntyp1) cycle
18403         positi=(mod(c(3,i+nres),boxzsize))
18404         if (positi.le.0) positi=positi+boxzsize
18405 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18406 !c for each residue check if it is in lipid or lipid water border area
18407 !C       respos=mod(c(3,i+nres),boxzsize)
18408 !C       print *,positi,bordlipbot,buflipbot
18409        if ((positi.gt.bordlipbot) &
18410        .and.(positi.lt.bordliptop)) then
18411 !C the energy transfer exist
18412         if (positi.lt.buflipbot) then
18413          fracinbuf=1.0d0-   &
18414            ((positi-bordlipbot)/lipbufthick)
18415 !C lipbufthick is thickenes of lipid buffore
18416          sslip=sscalelip(fracinbuf)
18417          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18418          eliptran=eliptran+sslip*liptranene(itype(i,1))
18419          gliptranx(3,i)=gliptranx(3,i) &
18420       +ssgradlip*liptranene(itype(i,1))
18421          gliptranc(3,i-1)= gliptranc(3,i-1) &
18422       +ssgradlip*liptranene(itype(i,1))
18423 !C         print *,"doing sccale for lower part"
18424         elseif (positi.gt.bufliptop) then
18425          fracinbuf=1.0d0-  &
18426       ((bordliptop-positi)/lipbufthick)
18427          sslip=sscalelip(fracinbuf)
18428          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18429          eliptran=eliptran+sslip*liptranene(itype(i,1))
18430          gliptranx(3,i)=gliptranx(3,i)  &
18431        +ssgradlip*liptranene(itype(i,1))
18432          gliptranc(3,i-1)= gliptranc(3,i-1) &
18433       +ssgradlip*liptranene(itype(i,1))
18434 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18435         else
18436          eliptran=eliptran+liptranene(itype(i,1))
18437 !C         print *,"I am in true lipid"
18438         endif
18439         endif ! if in lipid or buffor
18440 !C       else
18441 !C       eliptran=elpitran+0.0 ! I am in water
18442         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18443        enddo
18444        return
18445        end  subroutine Eliptransfer
18446 !----------------------------------NANO FUNCTIONS
18447 !C-----------------------------------------------------------------------
18448 !C-----------------------------------------------------------
18449 !C This subroutine is to mimic the histone like structure but as well can be
18450 !C utilizet to nanostructures (infinit) small modification has to be used to
18451 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18452 !C gradient has to be modified at the ends
18453 !C The energy function is Kihara potential
18454 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18455 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18456 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18457 !C simple Kihara potential
18458       subroutine calctube(Etube)
18459       real(kind=8),dimension(3) :: vectube
18460       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18461        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18462        sc_aa_tube,sc_bb_tube
18463       integer :: i,j,iti
18464       Etube=0.0d0
18465       do i=itube_start,itube_end
18466         enetube(i)=0.0d0
18467         enetube(i+nres)=0.0d0
18468       enddo
18469 !C first we calculate the distance from tube center
18470 !C for UNRES
18471        do i=itube_start,itube_end
18472 !C lets ommit dummy atoms for now
18473        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18474 !C now calculate distance from center of tube and direction vectors
18475       xmin=boxxsize
18476       ymin=boxysize
18477 ! Find minimum distance in periodic box
18478         do j=-1,1
18479          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18480          vectube(1)=vectube(1)+boxxsize*j
18481          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18482          vectube(2)=vectube(2)+boxysize*j
18483          xminact=abs(vectube(1)-tubecenter(1))
18484          yminact=abs(vectube(2)-tubecenter(2))
18485            if (xmin.gt.xminact) then
18486             xmin=xminact
18487             xtemp=vectube(1)
18488            endif
18489            if (ymin.gt.yminact) then
18490              ymin=yminact
18491              ytemp=vectube(2)
18492             endif
18493          enddo
18494       vectube(1)=xtemp
18495       vectube(2)=ytemp
18496       vectube(1)=vectube(1)-tubecenter(1)
18497       vectube(2)=vectube(2)-tubecenter(2)
18498
18499 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18500 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18501
18502 !C as the tube is infinity we do not calculate the Z-vector use of Z
18503 !C as chosen axis
18504       vectube(3)=0.0d0
18505 !C now calculte the distance
18506        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18507 !C now normalize vector
18508       vectube(1)=vectube(1)/tub_r
18509       vectube(2)=vectube(2)/tub_r
18510 !C calculte rdiffrence between r and r0
18511       rdiff=tub_r-tubeR0
18512 !C and its 6 power
18513       rdiff6=rdiff**6.0d0
18514 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18515        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18516 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18517 !C       print *,rdiff,rdiff6,pep_aa_tube
18518 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18519 !C now we calculate gradient
18520        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18521             6.0d0*pep_bb_tube)/rdiff6/rdiff
18522 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18523 !C     &rdiff,fac
18524 !C now direction of gg_tube vector
18525         do j=1,3
18526         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18527         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18528         enddo
18529         enddo
18530 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18531 !C        print *,gg_tube(1,0),"TU"
18532
18533
18534        do i=itube_start,itube_end
18535 !C Lets not jump over memory as we use many times iti
18536          iti=itype(i,1)
18537 !C lets ommit dummy atoms for now
18538          if ((iti.eq.ntyp1)  &
18539 !C in UNRES uncomment the line below as GLY has no side-chain...
18540 !C      .or.(iti.eq.10)
18541         ) cycle
18542       xmin=boxxsize
18543       ymin=boxysize
18544         do j=-1,1
18545          vectube(1)=mod((c(1,i+nres)),boxxsize)
18546          vectube(1)=vectube(1)+boxxsize*j
18547          vectube(2)=mod((c(2,i+nres)),boxysize)
18548          vectube(2)=vectube(2)+boxysize*j
18549
18550          xminact=abs(vectube(1)-tubecenter(1))
18551          yminact=abs(vectube(2)-tubecenter(2))
18552            if (xmin.gt.xminact) then
18553             xmin=xminact
18554             xtemp=vectube(1)
18555            endif
18556            if (ymin.gt.yminact) then
18557              ymin=yminact
18558              ytemp=vectube(2)
18559             endif
18560          enddo
18561       vectube(1)=xtemp
18562       vectube(2)=ytemp
18563 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18564 !C     &     tubecenter(2)
18565       vectube(1)=vectube(1)-tubecenter(1)
18566       vectube(2)=vectube(2)-tubecenter(2)
18567
18568 !C as the tube is infinity we do not calculate the Z-vector use of Z
18569 !C as chosen axis
18570       vectube(3)=0.0d0
18571 !C now calculte the distance
18572        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18573 !C now normalize vector
18574       vectube(1)=vectube(1)/tub_r
18575       vectube(2)=vectube(2)/tub_r
18576
18577 !C calculte rdiffrence between r and r0
18578       rdiff=tub_r-tubeR0
18579 !C and its 6 power
18580       rdiff6=rdiff**6.0d0
18581 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18582        sc_aa_tube=sc_aa_tube_par(iti)
18583        sc_bb_tube=sc_bb_tube_par(iti)
18584        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18585        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18586              6.0d0*sc_bb_tube/rdiff6/rdiff
18587 !C now direction of gg_tube vector
18588          do j=1,3
18589           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18590           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18591          enddo
18592         enddo
18593         do i=itube_start,itube_end
18594           Etube=Etube+enetube(i)+enetube(i+nres)
18595         enddo
18596 !C        print *,"ETUBE", etube
18597         return
18598         end subroutine calctube
18599 !C TO DO 1) add to total energy
18600 !C       2) add to gradient summation
18601 !C       3) add reading parameters (AND of course oppening of PARAM file)
18602 !C       4) add reading the center of tube
18603 !C       5) add COMMONs
18604 !C       6) add to zerograd
18605 !C       7) allocate matrices
18606
18607
18608 !C-----------------------------------------------------------------------
18609 !C-----------------------------------------------------------
18610 !C This subroutine is to mimic the histone like structure but as well can be
18611 !C utilizet to nanostructures (infinit) small modification has to be used to
18612 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18613 !C gradient has to be modified at the ends
18614 !C The energy function is Kihara potential
18615 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18616 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18617 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18618 !C simple Kihara potential
18619       subroutine calctube2(Etube)
18620             real(kind=8),dimension(3) :: vectube
18621       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18622        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18623        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18624       integer:: i,j,iti
18625       Etube=0.0d0
18626       do i=itube_start,itube_end
18627         enetube(i)=0.0d0
18628         enetube(i+nres)=0.0d0
18629       enddo
18630 !C first we calculate the distance from tube center
18631 !C first sugare-phosphate group for NARES this would be peptide group
18632 !C for UNRES
18633        do i=itube_start,itube_end
18634 !C lets ommit dummy atoms for now
18635
18636        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18637 !C now calculate distance from center of tube and direction vectors
18638 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18639 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18640 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18641 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18642       xmin=boxxsize
18643       ymin=boxysize
18644         do j=-1,1
18645          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18646          vectube(1)=vectube(1)+boxxsize*j
18647          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18648          vectube(2)=vectube(2)+boxysize*j
18649
18650          xminact=abs(vectube(1)-tubecenter(1))
18651          yminact=abs(vectube(2)-tubecenter(2))
18652            if (xmin.gt.xminact) then
18653             xmin=xminact
18654             xtemp=vectube(1)
18655            endif
18656            if (ymin.gt.yminact) then
18657              ymin=yminact
18658              ytemp=vectube(2)
18659             endif
18660          enddo
18661       vectube(1)=xtemp
18662       vectube(2)=ytemp
18663       vectube(1)=vectube(1)-tubecenter(1)
18664       vectube(2)=vectube(2)-tubecenter(2)
18665
18666 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18667 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18668
18669 !C as the tube is infinity we do not calculate the Z-vector use of Z
18670 !C as chosen axis
18671       vectube(3)=0.0d0
18672 !C now calculte the distance
18673        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18674 !C now normalize vector
18675       vectube(1)=vectube(1)/tub_r
18676       vectube(2)=vectube(2)/tub_r
18677 !C calculte rdiffrence between r and r0
18678       rdiff=tub_r-tubeR0
18679 !C and its 6 power
18680       rdiff6=rdiff**6.0d0
18681 !C THIS FRAGMENT MAKES TUBE FINITE
18682         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18683         if (positi.le.0) positi=positi+boxzsize
18684 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18685 !c for each residue check if it is in lipid or lipid water border area
18686 !C       respos=mod(c(3,i+nres),boxzsize)
18687 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18688        if ((positi.gt.bordtubebot)  &
18689         .and.(positi.lt.bordtubetop)) then
18690 !C the energy transfer exist
18691         if (positi.lt.buftubebot) then
18692          fracinbuf=1.0d0-  &
18693            ((positi-bordtubebot)/tubebufthick)
18694 !C lipbufthick is thickenes of lipid buffore
18695          sstube=sscalelip(fracinbuf)
18696          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18697 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18698          enetube(i)=enetube(i)+sstube*tubetranenepep
18699 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18700 !C     &+ssgradtube*tubetranene(itype(i,1))
18701 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18702 !C     &+ssgradtube*tubetranene(itype(i,1))
18703 !C         print *,"doing sccale for lower part"
18704         elseif (positi.gt.buftubetop) then
18705          fracinbuf=1.0d0-  &
18706         ((bordtubetop-positi)/tubebufthick)
18707          sstube=sscalelip(fracinbuf)
18708          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18709          enetube(i)=enetube(i)+sstube*tubetranenepep
18710 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18711 !C     &+ssgradtube*tubetranene(itype(i,1))
18712 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18713 !C     &+ssgradtube*tubetranene(itype(i,1))
18714 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18715         else
18716          sstube=1.0d0
18717          ssgradtube=0.0d0
18718          enetube(i)=enetube(i)+sstube*tubetranenepep
18719 !C         print *,"I am in true lipid"
18720         endif
18721         else
18722 !C          sstube=0.0d0
18723 !C          ssgradtube=0.0d0
18724         cycle
18725         endif ! if in lipid or buffor
18726
18727 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18728        enetube(i)=enetube(i)+sstube* &
18729         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18730 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18731 !C       print *,rdiff,rdiff6,pep_aa_tube
18732 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18733 !C now we calculate gradient
18734        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18735              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18736 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18737 !C     &rdiff,fac
18738
18739 !C now direction of gg_tube vector
18740        do j=1,3
18741         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18742         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18743         enddo
18744          gg_tube(3,i)=gg_tube(3,i)  &
18745        +ssgradtube*enetube(i)/sstube/2.0d0
18746          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18747        +ssgradtube*enetube(i)/sstube/2.0d0
18748
18749         enddo
18750 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18751 !C        print *,gg_tube(1,0),"TU"
18752         do i=itube_start,itube_end
18753 !C Lets not jump over memory as we use many times iti
18754          iti=itype(i,1)
18755 !C lets ommit dummy atoms for now
18756          if ((iti.eq.ntyp1) &
18757 !!C in UNRES uncomment the line below as GLY has no side-chain...
18758            .or.(iti.eq.10) &
18759           ) cycle
18760           vectube(1)=c(1,i+nres)
18761           vectube(1)=mod(vectube(1),boxxsize)
18762           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18763           vectube(2)=c(2,i+nres)
18764           vectube(2)=mod(vectube(2),boxysize)
18765           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18766
18767       vectube(1)=vectube(1)-tubecenter(1)
18768       vectube(2)=vectube(2)-tubecenter(2)
18769 !C THIS FRAGMENT MAKES TUBE FINITE
18770         positi=(mod(c(3,i+nres),boxzsize))
18771         if (positi.le.0) positi=positi+boxzsize
18772 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18773 !c for each residue check if it is in lipid or lipid water border area
18774 !C       respos=mod(c(3,i+nres),boxzsize)
18775 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18776
18777        if ((positi.gt.bordtubebot)  &
18778         .and.(positi.lt.bordtubetop)) then
18779 !C the energy transfer exist
18780         if (positi.lt.buftubebot) then
18781          fracinbuf=1.0d0- &
18782             ((positi-bordtubebot)/tubebufthick)
18783 !C lipbufthick is thickenes of lipid buffore
18784          sstube=sscalelip(fracinbuf)
18785          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18786 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18787          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18788 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18789 !C     &+ssgradtube*tubetranene(itype(i,1))
18790 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18791 !C     &+ssgradtube*tubetranene(itype(i,1))
18792 !C         print *,"doing sccale for lower part"
18793         elseif (positi.gt.buftubetop) then
18794          fracinbuf=1.0d0- &
18795         ((bordtubetop-positi)/tubebufthick)
18796
18797          sstube=sscalelip(fracinbuf)
18798          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18799          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18800 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18801 !C     &+ssgradtube*tubetranene(itype(i,1))
18802 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18803 !C     &+ssgradtube*tubetranene(itype(i,1))
18804 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18805         else
18806          sstube=1.0d0
18807          ssgradtube=0.0d0
18808          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18809 !C         print *,"I am in true lipid"
18810         endif
18811         else
18812 !C          sstube=0.0d0
18813 !C          ssgradtube=0.0d0
18814         cycle
18815         endif ! if in lipid or buffor
18816 !CEND OF FINITE FRAGMENT
18817 !C as the tube is infinity we do not calculate the Z-vector use of Z
18818 !C as chosen axis
18819       vectube(3)=0.0d0
18820 !C now calculte the distance
18821        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18822 !C now normalize vector
18823       vectube(1)=vectube(1)/tub_r
18824       vectube(2)=vectube(2)/tub_r
18825 !C calculte rdiffrence between r and r0
18826       rdiff=tub_r-tubeR0
18827 !C and its 6 power
18828       rdiff6=rdiff**6.0d0
18829 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18830        sc_aa_tube=sc_aa_tube_par(iti)
18831        sc_bb_tube=sc_bb_tube_par(iti)
18832        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
18833                        *sstube+enetube(i+nres)
18834 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18835 !C now we calculate gradient
18836        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
18837             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
18838 !C now direction of gg_tube vector
18839          do j=1,3
18840           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18841           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18842          enddo
18843          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
18844        +ssgradtube*enetube(i+nres)/sstube
18845          gg_tube(3,i-1)= gg_tube(3,i-1) &
18846        +ssgradtube*enetube(i+nres)/sstube
18847
18848         enddo
18849         do i=itube_start,itube_end
18850           Etube=Etube+enetube(i)+enetube(i+nres)
18851         enddo
18852 !C        print *,"ETUBE", etube
18853         return
18854         end subroutine calctube2
18855 !=====================================================================================================================================
18856       subroutine calcnano(Etube)
18857       real(kind=8),dimension(3) :: vectube
18858
18859       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18860        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
18861        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
18862        integer:: i,j,iti,r
18863
18864       Etube=0.0d0
18865 !      print *,itube_start,itube_end,"poczatek"
18866       do i=itube_start,itube_end
18867         enetube(i)=0.0d0
18868         enetube(i+nres)=0.0d0
18869       enddo
18870 !C first we calculate the distance from tube center
18871 !C first sugare-phosphate group for NARES this would be peptide group
18872 !C for UNRES
18873        do i=itube_start,itube_end
18874 !C lets ommit dummy atoms for now
18875        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18876 !C now calculate distance from center of tube and direction vectors
18877       xmin=boxxsize
18878       ymin=boxysize
18879       zmin=boxzsize
18880
18881         do j=-1,1
18882          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18883          vectube(1)=vectube(1)+boxxsize*j
18884          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18885          vectube(2)=vectube(2)+boxysize*j
18886          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18887          vectube(3)=vectube(3)+boxzsize*j
18888
18889
18890          xminact=dabs(vectube(1)-tubecenter(1))
18891          yminact=dabs(vectube(2)-tubecenter(2))
18892          zminact=dabs(vectube(3)-tubecenter(3))
18893
18894            if (xmin.gt.xminact) then
18895             xmin=xminact
18896             xtemp=vectube(1)
18897            endif
18898            if (ymin.gt.yminact) then
18899              ymin=yminact
18900              ytemp=vectube(2)
18901             endif
18902            if (zmin.gt.zminact) then
18903              zmin=zminact
18904              ztemp=vectube(3)
18905             endif
18906          enddo
18907       vectube(1)=xtemp
18908       vectube(2)=ytemp
18909       vectube(3)=ztemp
18910
18911       vectube(1)=vectube(1)-tubecenter(1)
18912       vectube(2)=vectube(2)-tubecenter(2)
18913       vectube(3)=vectube(3)-tubecenter(3)
18914
18915 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18916 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18917 !C as the tube is infinity we do not calculate the Z-vector use of Z
18918 !C as chosen axis
18919 !C      vectube(3)=0.0d0
18920 !C now calculte the distance
18921        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18922 !C now normalize vector
18923       vectube(1)=vectube(1)/tub_r
18924       vectube(2)=vectube(2)/tub_r
18925       vectube(3)=vectube(3)/tub_r
18926 !C calculte rdiffrence between r and r0
18927       rdiff=tub_r-tubeR0
18928 !C and its 6 power
18929       rdiff6=rdiff**6.0d0
18930 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18931        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18932 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18933 !C       print *,rdiff,rdiff6,pep_aa_tube
18934 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18935 !C now we calculate gradient
18936        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
18937             6.0d0*pep_bb_tube)/rdiff6/rdiff
18938 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18939 !C     &rdiff,fac
18940          if (acavtubpep.eq.0.0d0) then
18941 !C go to 667
18942          enecavtube(i)=0.0
18943          faccav=0.0
18944          else
18945          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
18946          enecavtube(i)=  &
18947         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
18948         /denominator
18949          enecavtube(i)=0.0
18950          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
18951         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
18952         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
18953         /denominator**2.0d0
18954 !C         faccav=0.0
18955 !C         fac=fac+faccav
18956 !C 667     continue
18957          endif
18958           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
18959         do j=1,3
18960         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18961         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18962         enddo
18963         enddo
18964
18965        do i=itube_start,itube_end
18966         enecavtube(i)=0.0d0
18967 !C Lets not jump over memory as we use many times iti
18968          iti=itype(i,1)
18969 !C lets ommit dummy atoms for now
18970          if ((iti.eq.ntyp1) &
18971 !C in UNRES uncomment the line below as GLY has no side-chain...
18972 !C      .or.(iti.eq.10)
18973          ) cycle
18974       xmin=boxxsize
18975       ymin=boxysize
18976       zmin=boxzsize
18977         do j=-1,1
18978          vectube(1)=dmod((c(1,i+nres)),boxxsize)
18979          vectube(1)=vectube(1)+boxxsize*j
18980          vectube(2)=dmod((c(2,i+nres)),boxysize)
18981          vectube(2)=vectube(2)+boxysize*j
18982          vectube(3)=dmod((c(3,i+nres)),boxzsize)
18983          vectube(3)=vectube(3)+boxzsize*j
18984
18985
18986          xminact=dabs(vectube(1)-tubecenter(1))
18987          yminact=dabs(vectube(2)-tubecenter(2))
18988          zminact=dabs(vectube(3)-tubecenter(3))
18989
18990            if (xmin.gt.xminact) then
18991             xmin=xminact
18992             xtemp=vectube(1)
18993            endif
18994            if (ymin.gt.yminact) then
18995              ymin=yminact
18996              ytemp=vectube(2)
18997             endif
18998            if (zmin.gt.zminact) then
18999              zmin=zminact
19000              ztemp=vectube(3)
19001             endif
19002          enddo
19003       vectube(1)=xtemp
19004       vectube(2)=ytemp
19005       vectube(3)=ztemp
19006
19007 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19008 !C     &     tubecenter(2)
19009       vectube(1)=vectube(1)-tubecenter(1)
19010       vectube(2)=vectube(2)-tubecenter(2)
19011       vectube(3)=vectube(3)-tubecenter(3)
19012 !C now calculte the distance
19013        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19014 !C now normalize vector
19015       vectube(1)=vectube(1)/tub_r
19016       vectube(2)=vectube(2)/tub_r
19017       vectube(3)=vectube(3)/tub_r
19018
19019 !C calculte rdiffrence between r and r0
19020       rdiff=tub_r-tubeR0
19021 !C and its 6 power
19022       rdiff6=rdiff**6.0d0
19023        sc_aa_tube=sc_aa_tube_par(iti)
19024        sc_bb_tube=sc_bb_tube_par(iti)
19025        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19026 !C       enetube(i+nres)=0.0d0
19027 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19028 !C now we calculate gradient
19029        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19030             6.0d0*sc_bb_tube/rdiff6/rdiff
19031 !C       fac=0.0
19032 !C now direction of gg_tube vector
19033 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19034          if (acavtub(iti).eq.0.0d0) then
19035 !C go to 667
19036          enecavtube(i+nres)=0.0d0
19037          faccav=0.0d0
19038          else
19039          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19040          enecavtube(i+nres)=   &
19041         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19042         /denominator
19043 !C         enecavtube(i)=0.0
19044          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19045         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19046         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19047         /denominator**2.0d0
19048 !C         faccav=0.0
19049          fac=fac+faccav
19050 !C 667     continue
19051          endif
19052 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19053 !C     &   enecavtube(i),faccav
19054 !C         print *,"licz=",
19055 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19056 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19057          do j=1,3
19058           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19059           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19060          enddo
19061           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19062         enddo
19063
19064
19065
19066         do i=itube_start,itube_end
19067           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19068          +enecavtube(i+nres)
19069         enddo
19070 !        do i=1,20
19071 !         print *,"begin", i,"a"
19072 !         do r=1,10000
19073 !          rdiff=r/100.0d0
19074 !          rdiff6=rdiff**6.0d0
19075 !          sc_aa_tube=sc_aa_tube_par(i)
19076 !          sc_bb_tube=sc_bb_tube_par(i)
19077 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19078 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19079 !          enecavtube(i)=   &
19080 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19081 !         /denominator
19082
19083 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19084 !         enddo
19085 !         print *,"end",i,"a"
19086 !        enddo
19087 !C        print *,"ETUBE", etube
19088         return
19089         end subroutine calcnano
19090
19091 !===============================================
19092 !--------------------------------------------------------------------------------
19093 !C first for shielding is setting of function of side-chains
19094
19095        subroutine set_shield_fac2
19096        real(kind=8) :: div77_81=0.974996043d0, &
19097         div4_81=0.2222222222d0
19098        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19099          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19100          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19101          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19102 !C the vector between center of side_chain and peptide group
19103        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19104          pept_group,costhet_grad,cosphi_grad_long, &
19105          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19106          sh_frac_dist_grad,pep_side
19107         integer i,j,k
19108 !C      write(2,*) "ivec",ivec_start,ivec_end
19109       do i=1,nres
19110         fac_shield(i)=0.0d0
19111         do j=1,3
19112         grad_shield(j,i)=0.0d0
19113         enddo
19114       enddo
19115       do i=ivec_start,ivec_end
19116 !C      do i=1,nres-1
19117 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19118       ishield_list(i)=0
19119       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19120 !Cif there two consequtive dummy atoms there is no peptide group between them
19121 !C the line below has to be changed for FGPROC>1
19122       VolumeTotal=0.0
19123       do k=1,nres
19124        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19125        dist_pep_side=0.0
19126        dist_side_calf=0.0
19127        do j=1,3
19128 !C first lets set vector conecting the ithe side-chain with kth side-chain
19129       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19130 !C      pep_side(j)=2.0d0
19131 !C and vector conecting the side-chain with its proper calfa
19132       side_calf(j)=c(j,k+nres)-c(j,k)
19133 !C      side_calf(j)=2.0d0
19134       pept_group(j)=c(j,i)-c(j,i+1)
19135 !C lets have their lenght
19136       dist_pep_side=pep_side(j)**2+dist_pep_side
19137       dist_side_calf=dist_side_calf+side_calf(j)**2
19138       dist_pept_group=dist_pept_group+pept_group(j)**2
19139       enddo
19140        dist_pep_side=sqrt(dist_pep_side)
19141        dist_pept_group=sqrt(dist_pept_group)
19142        dist_side_calf=sqrt(dist_side_calf)
19143       do j=1,3
19144         pep_side_norm(j)=pep_side(j)/dist_pep_side
19145         side_calf_norm(j)=dist_side_calf
19146       enddo
19147 !C now sscale fraction
19148        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19149 !C       print *,buff_shield,"buff"
19150 !C now sscale
19151         if (sh_frac_dist.le.0.0) cycle
19152 !C        print *,ishield_list(i),i
19153 !C If we reach here it means that this side chain reaches the shielding sphere
19154 !C Lets add him to the list for gradient
19155         ishield_list(i)=ishield_list(i)+1
19156 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19157 !C this list is essential otherwise problem would be O3
19158         shield_list(ishield_list(i),i)=k
19159 !C Lets have the sscale value
19160         if (sh_frac_dist.gt.1.0) then
19161          scale_fac_dist=1.0d0
19162          do j=1,3
19163          sh_frac_dist_grad(j)=0.0d0
19164          enddo
19165         else
19166          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19167                         *(2.0d0*sh_frac_dist-3.0d0)
19168          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19169                        /dist_pep_side/buff_shield*0.5d0
19170          do j=1,3
19171          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19172 !C         sh_frac_dist_grad(j)=0.0d0
19173 !C         scale_fac_dist=1.0d0
19174 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19175 !C     &                    sh_frac_dist_grad(j)
19176          enddo
19177         endif
19178 !C this is what is now we have the distance scaling now volume...
19179       short=short_r_sidechain(itype(k,1))
19180       long=long_r_sidechain(itype(k,1))
19181       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19182       sinthet=short/dist_pep_side*costhet
19183 !C now costhet_grad
19184 !C       costhet=0.6d0
19185 !C       sinthet=0.8
19186        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19187 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19188 !C     &             -short/dist_pep_side**2/costhet)
19189 !C       costhet_fac=0.0d0
19190        do j=1,3
19191          costhet_grad(j)=costhet_fac*pep_side(j)
19192        enddo
19193 !C remember for the final gradient multiply costhet_grad(j)
19194 !C for side_chain by factor -2 !
19195 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19196 !C pep_side0pept_group is vector multiplication
19197       pep_side0pept_group=0.0d0
19198       do j=1,3
19199       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19200       enddo
19201       cosalfa=(pep_side0pept_group/ &
19202       (dist_pep_side*dist_side_calf))
19203       fac_alfa_sin=1.0d0-cosalfa**2
19204       fac_alfa_sin=dsqrt(fac_alfa_sin)
19205       rkprim=fac_alfa_sin*(long-short)+short
19206 !C      rkprim=short
19207
19208 !C now costhet_grad
19209        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19210 !C       cosphi=0.6
19211        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19212        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19213            dist_pep_side**2)
19214 !C       sinphi=0.8
19215        do j=1,3
19216          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19217       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19218       *(long-short)/fac_alfa_sin*cosalfa/ &
19219       ((dist_pep_side*dist_side_calf))* &
19220       ((side_calf(j))-cosalfa* &
19221       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19222 !C       cosphi_grad_long(j)=0.0d0
19223         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19224       *(long-short)/fac_alfa_sin*cosalfa &
19225       /((dist_pep_side*dist_side_calf))* &
19226       (pep_side(j)- &
19227       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19228 !C       cosphi_grad_loc(j)=0.0d0
19229        enddo
19230 !C      print *,sinphi,sinthet
19231       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19232      &                    /VSolvSphere_div
19233 !C     &                    *wshield
19234 !C now the gradient...
19235       do j=1,3
19236       grad_shield(j,i)=grad_shield(j,i) &
19237 !C gradient po skalowaniu
19238                      +(sh_frac_dist_grad(j)*VofOverlap &
19239 !C  gradient po costhet
19240             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19241         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19242             sinphi/sinthet*costhet*costhet_grad(j) &
19243            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19244         )*wshield
19245 !C grad_shield_side is Cbeta sidechain gradient
19246       grad_shield_side(j,ishield_list(i),i)=&
19247              (sh_frac_dist_grad(j)*-2.0d0&
19248              *VofOverlap&
19249             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19250        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19251             sinphi/sinthet*costhet*costhet_grad(j)&
19252            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19253             )*wshield
19254
19255        grad_shield_loc(j,ishield_list(i),i)=   &
19256             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19257       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19258             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19259              ))&
19260              *wshield
19261       enddo
19262       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19263       enddo
19264       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19265
19266 !C      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19267       enddo
19268       return
19269       end subroutine set_shield_fac2
19270 !----------------------------------------------------------------------------
19271 ! SOUBROUTINE FOR AFM
19272        subroutine AFMvel(Eafmforce)
19273        use MD_data, only:totTafm
19274       real(kind=8),dimension(3) :: diffafm
19275       real(kind=8) :: afmdist,Eafmforce
19276        integer :: i
19277 !C Only for check grad COMMENT if not used for checkgrad
19278 !C      totT=3.0d0
19279 !C--------------------------------------------------------
19280 !C      print *,"wchodze"
19281       afmdist=0.0d0
19282       Eafmforce=0.0d0
19283       do i=1,3
19284       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19285       afmdist=afmdist+diffafm(i)**2
19286       enddo
19287       afmdist=dsqrt(afmdist)
19288 !      totTafm=3.0
19289       Eafmforce=0.5d0*forceAFMconst &
19290       *(distafminit+totTafm*velAFMconst-afmdist)**2
19291 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19292       do i=1,3
19293       gradafm(i,afmend-1)=-forceAFMconst* &
19294        (distafminit+totTafm*velAFMconst-afmdist) &
19295        *diffafm(i)/afmdist
19296       gradafm(i,afmbeg-1)=forceAFMconst* &
19297       (distafminit+totTafm*velAFMconst-afmdist) &
19298       *diffafm(i)/afmdist
19299       enddo
19300 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19301       return
19302       end subroutine AFMvel
19303 !---------------------------------------------------------
19304        subroutine AFMforce(Eafmforce)
19305
19306       real(kind=8),dimension(3) :: diffafm
19307 !      real(kind=8) ::afmdist
19308       real(kind=8) :: afmdist,Eafmforce
19309       integer :: i
19310       afmdist=0.0d0
19311       Eafmforce=0.0d0
19312       do i=1,3
19313       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19314       afmdist=afmdist+diffafm(i)**2
19315       enddo
19316       afmdist=dsqrt(afmdist)
19317 !      print *,afmdist,distafminit
19318       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19319       do i=1,3
19320       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19321       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19322       enddo
19323 !C      print *,'AFM',Eafmforce
19324       return
19325       end subroutine AFMforce
19326
19327 !-----------------------------------------------------------------------------
19328 #ifdef WHAM
19329       subroutine read_ssHist
19330 !      implicit none
19331 !      Includes
19332 !      include 'DIMENSIONS'
19333 !      include "DIMENSIONS.FREE"
19334 !      include 'COMMON.FREE'
19335 !     Local variables
19336       integer :: i,j
19337       character(len=80) :: controlcard
19338
19339       do i=1,dyn_nssHist
19340         call card_concat(controlcard,.true.)
19341         read(controlcard,*) &
19342              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19343       enddo
19344
19345       return
19346       end subroutine read_ssHist
19347 #endif
19348 !-----------------------------------------------------------------------------
19349       integer function indmat(i,j)
19350 !el
19351 ! get the position of the jth ijth fragment of the chain coordinate system
19352 ! in the fromto array.
19353         integer :: i,j
19354
19355         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19356       return
19357       end function indmat
19358 !-----------------------------------------------------------------------------
19359       real(kind=8) function sigm(x)
19360 !el
19361        real(kind=8) :: x
19362         sigm=0.25d0*x
19363       return
19364       end function sigm
19365 !-----------------------------------------------------------------------------
19366 !-----------------------------------------------------------------------------
19367       subroutine alloc_ener_arrays
19368 !EL Allocation of arrays used by module energy
19369       use MD_data, only: mset
19370 !el local variables
19371       integer :: i,j
19372
19373       if(nres.lt.100) then
19374         maxconts=nres
19375       elseif(nres.lt.200) then
19376         maxconts=0.8*nres       ! Max. number of contacts per residue
19377       else
19378         maxconts=0.6*nres ! (maxconts=maxres/4)
19379       endif
19380       maxcont=12*nres   ! Max. number of SC contacts
19381       maxvar=6*nres     ! Max. number of variables
19382 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19383       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19384 !----------------------
19385 ! arrays in subroutine init_int_table
19386 !el#ifdef MPI
19387 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19388 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19389 !el#endif
19390       allocate(nint_gr(nres))
19391       allocate(nscp_gr(nres))
19392       allocate(ielstart(nres))
19393       allocate(ielend(nres))
19394 !(maxres)
19395       allocate(istart(nres,maxint_gr))
19396       allocate(iend(nres,maxint_gr))
19397 !(maxres,maxint_gr)
19398       allocate(iscpstart(nres,maxint_gr))
19399       allocate(iscpend(nres,maxint_gr))
19400 !(maxres,maxint_gr)
19401       allocate(ielstart_vdw(nres))
19402       allocate(ielend_vdw(nres))
19403 !(maxres)
19404       allocate(nint_gr_nucl(nres))
19405       allocate(nscp_gr_nucl(nres))
19406       allocate(ielstart_nucl(nres))
19407       allocate(ielend_nucl(nres))
19408 !(maxres)
19409       allocate(istart_nucl(nres,maxint_gr))
19410       allocate(iend_nucl(nres,maxint_gr))
19411 !(maxres,maxint_gr)
19412       allocate(iscpstart_nucl(nres,maxint_gr))
19413       allocate(iscpend_nucl(nres,maxint_gr))
19414 !(maxres,maxint_gr)
19415       allocate(ielstart_vdw_nucl(nres))
19416       allocate(ielend_vdw_nucl(nres))
19417
19418       allocate(lentyp(0:nfgtasks-1))
19419 !(0:maxprocs-1)
19420 !----------------------
19421 ! commom.contacts
19422 !      common /contacts/
19423       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19424       allocate(icont(2,maxcont))
19425 !(2,maxcont)
19426 !      common /contacts1/
19427       allocate(num_cont(0:nres+4))
19428 !(maxres)
19429       allocate(jcont(maxconts,nres))
19430 !(maxconts,maxres)
19431       allocate(facont(maxconts,nres))
19432 !(maxconts,maxres)
19433       allocate(gacont(3,maxconts,nres))
19434 !(3,maxconts,maxres)
19435 !      common /contacts_hb/
19436       allocate(gacontp_hb1(3,maxconts,nres))
19437       allocate(gacontp_hb2(3,maxconts,nres))
19438       allocate(gacontp_hb3(3,maxconts,nres))
19439       allocate(gacontm_hb1(3,maxconts,nres))
19440       allocate(gacontm_hb2(3,maxconts,nres))
19441       allocate(gacontm_hb3(3,maxconts,nres))
19442       allocate(gacont_hbr(3,maxconts,nres))
19443       allocate(grij_hb_cont(3,maxconts,nres))
19444 !(3,maxconts,maxres)
19445       allocate(facont_hb(maxconts,nres))
19446
19447       allocate(ees0p(maxconts,nres))
19448       allocate(ees0m(maxconts,nres))
19449       allocate(d_cont(maxconts,nres))
19450       allocate(ees0plist(maxconts,nres))
19451
19452 !(maxconts,maxres)
19453       allocate(num_cont_hb(nres))
19454 !(maxres)
19455       allocate(jcont_hb(maxconts,nres))
19456 !(maxconts,maxres)
19457 !      common /rotat/
19458       allocate(Ug(2,2,nres))
19459       allocate(Ugder(2,2,nres))
19460       allocate(Ug2(2,2,nres))
19461       allocate(Ug2der(2,2,nres))
19462 !(2,2,maxres)
19463       allocate(obrot(2,nres))
19464       allocate(obrot2(2,nres))
19465       allocate(obrot_der(2,nres))
19466       allocate(obrot2_der(2,nres))
19467 !(2,maxres)
19468 !      common /precomp1/
19469       allocate(mu(2,nres))
19470       allocate(muder(2,nres))
19471       allocate(Ub2(2,nres))
19472       Ub2(1,:)=0.0d0
19473       Ub2(2,:)=0.0d0
19474       allocate(Ub2der(2,nres))
19475       allocate(Ctobr(2,nres))
19476       allocate(Ctobrder(2,nres))
19477       allocate(Dtobr2(2,nres))
19478       allocate(Dtobr2der(2,nres))
19479 !(2,maxres)
19480       allocate(EUg(2,2,nres))
19481       allocate(EUgder(2,2,nres))
19482       allocate(CUg(2,2,nres))
19483       allocate(CUgder(2,2,nres))
19484       allocate(DUg(2,2,nres))
19485       allocate(Dugder(2,2,nres))
19486       allocate(DtUg2(2,2,nres))
19487       allocate(DtUg2der(2,2,nres))
19488 !(2,2,maxres)
19489 !      common /precomp2/
19490       allocate(Ug2Db1t(2,nres))
19491       allocate(Ug2Db1tder(2,nres))
19492       allocate(CUgb2(2,nres))
19493       allocate(CUgb2der(2,nres))
19494 !(2,maxres)
19495       allocate(EUgC(2,2,nres))
19496       allocate(EUgCder(2,2,nres))
19497       allocate(EUgD(2,2,nres))
19498       allocate(EUgDder(2,2,nres))
19499       allocate(DtUg2EUg(2,2,nres))
19500       allocate(Ug2DtEUg(2,2,nres))
19501 !(2,2,maxres)
19502       allocate(Ug2DtEUgder(2,2,2,nres))
19503       allocate(DtUg2EUgder(2,2,2,nres))
19504 !(2,2,2,maxres)
19505 !      common /rotat_old/
19506       allocate(costab(nres))
19507       allocate(sintab(nres))
19508       allocate(costab2(nres))
19509       allocate(sintab2(nres))
19510 !(maxres)
19511 !      common /dipmat/
19512       allocate(a_chuj(2,2,maxconts,nres))
19513 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19514       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19515 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19516 !      common /contdistrib/
19517       allocate(ncont_sent(nres))
19518       allocate(ncont_recv(nres))
19519
19520       allocate(iat_sent(nres))
19521 !(maxres)
19522       allocate(iint_sent(4,nres,nres))
19523       allocate(iint_sent_local(4,nres,nres))
19524 !(4,maxres,maxres)
19525       allocate(iturn3_sent(4,0:nres+4))
19526       allocate(iturn4_sent(4,0:nres+4))
19527       allocate(iturn3_sent_local(4,nres))
19528       allocate(iturn4_sent_local(4,nres))
19529 !(4,maxres)
19530       allocate(itask_cont_from(0:nfgtasks-1))
19531       allocate(itask_cont_to(0:nfgtasks-1))
19532 !(0:max_fg_procs-1)
19533
19534
19535
19536 !----------------------
19537 ! commom.deriv;
19538 !      common /derivat/
19539       allocate(dcdv(6,maxdim))
19540       allocate(dxdv(6,maxdim))
19541 !(6,maxdim)
19542       allocate(dxds(6,nres))
19543 !(6,maxres)
19544       allocate(gradx(3,-1:nres,0:2))
19545       allocate(gradc(3,-1:nres,0:2))
19546 !(3,maxres,2)
19547       allocate(gvdwx(3,-1:nres))
19548       allocate(gvdwc(3,-1:nres))
19549       allocate(gelc(3,-1:nres))
19550       allocate(gelc_long(3,-1:nres))
19551       allocate(gvdwpp(3,-1:nres))
19552       allocate(gvdwc_scpp(3,-1:nres))
19553       allocate(gradx_scp(3,-1:nres))
19554       allocate(gvdwc_scp(3,-1:nres))
19555       allocate(ghpbx(3,-1:nres))
19556       allocate(ghpbc(3,-1:nres))
19557       allocate(gradcorr(3,-1:nres))
19558       allocate(gradcorr_long(3,-1:nres))
19559       allocate(gradcorr5_long(3,-1:nres))
19560       allocate(gradcorr6_long(3,-1:nres))
19561       allocate(gcorr6_turn_long(3,-1:nres))
19562       allocate(gradxorr(3,-1:nres))
19563       allocate(gradcorr5(3,-1:nres))
19564       allocate(gradcorr6(3,-1:nres))
19565       allocate(gliptran(3,-1:nres))
19566       allocate(gliptranc(3,-1:nres))
19567       allocate(gliptranx(3,-1:nres))
19568       allocate(gshieldx(3,-1:nres))
19569       allocate(gshieldc(3,-1:nres))
19570       allocate(gshieldc_loc(3,-1:nres))
19571       allocate(gshieldx_ec(3,-1:nres))
19572       allocate(gshieldc_ec(3,-1:nres))
19573       allocate(gshieldc_loc_ec(3,-1:nres))
19574       allocate(gshieldx_t3(3,-1:nres))
19575       allocate(gshieldc_t3(3,-1:nres))
19576       allocate(gshieldc_loc_t3(3,-1:nres))
19577       allocate(gshieldx_t4(3,-1:nres))
19578       allocate(gshieldc_t4(3,-1:nres))
19579       allocate(gshieldc_loc_t4(3,-1:nres))
19580       allocate(gshieldx_ll(3,-1:nres))
19581       allocate(gshieldc_ll(3,-1:nres))
19582       allocate(gshieldc_loc_ll(3,-1:nres))
19583       allocate(grad_shield(3,-1:nres))
19584       allocate(gg_tube_sc(3,-1:nres))
19585       allocate(gg_tube(3,-1:nres))
19586       allocate(gradafm(3,-1:nres))
19587       allocate(gradb_nucl(3,-1:nres))
19588       allocate(gradbx_nucl(3,-1:nres))
19589       allocate(gvdwpsb1(3,-1:nres))
19590       allocate(gelpp(3,-1:nres))
19591       allocate(gvdwpsb(3,-1:nres))
19592       allocate(gelsbc(3,-1:nres))
19593       allocate(gelsbx(3,-1:nres))
19594       allocate(gvdwsbx(3,-1:nres))
19595       allocate(gvdwsbc(3,-1:nres))
19596 !(3,maxres)
19597       allocate(grad_shield_side(3,50,nres))
19598       allocate(grad_shield_loc(3,50,nres))
19599 ! grad for shielding surroing
19600       allocate(gloc(0:maxvar,0:2))
19601       allocate(gloc_x(0:maxvar,2))
19602 !(maxvar,2)
19603       allocate(gel_loc(3,-1:nres))
19604       allocate(gel_loc_long(3,-1:nres))
19605       allocate(gcorr3_turn(3,-1:nres))
19606       allocate(gcorr4_turn(3,-1:nres))
19607       allocate(gcorr6_turn(3,-1:nres))
19608       allocate(gradb(3,-1:nres))
19609       allocate(gradbx(3,-1:nres))
19610 !(3,maxres)
19611       allocate(gel_loc_loc(maxvar))
19612       allocate(gel_loc_turn3(maxvar))
19613       allocate(gel_loc_turn4(maxvar))
19614       allocate(gel_loc_turn6(maxvar))
19615       allocate(gcorr_loc(maxvar))
19616       allocate(g_corr5_loc(maxvar))
19617       allocate(g_corr6_loc(maxvar))
19618 !(maxvar)
19619       allocate(gsccorc(3,-1:nres))
19620       allocate(gsccorx(3,-1:nres))
19621 !(3,maxres)
19622       allocate(gsccor_loc(-1:nres))
19623 !(maxres)
19624       allocate(dtheta(3,2,-1:nres))
19625 !(3,2,maxres)
19626       allocate(gscloc(3,-1:nres))
19627       allocate(gsclocx(3,-1:nres))
19628 !(3,maxres)
19629       allocate(dphi(3,3,-1:nres))
19630       allocate(dalpha(3,3,-1:nres))
19631       allocate(domega(3,3,-1:nres))
19632 !(3,3,maxres)
19633 !      common /deriv_scloc/
19634       allocate(dXX_C1tab(3,nres))
19635       allocate(dYY_C1tab(3,nres))
19636       allocate(dZZ_C1tab(3,nres))
19637       allocate(dXX_Ctab(3,nres))
19638       allocate(dYY_Ctab(3,nres))
19639       allocate(dZZ_Ctab(3,nres))
19640       allocate(dXX_XYZtab(3,nres))
19641       allocate(dYY_XYZtab(3,nres))
19642       allocate(dZZ_XYZtab(3,nres))
19643 !(3,maxres)
19644 !      common /mpgrad/
19645       allocate(jgrad_start(nres))
19646       allocate(jgrad_end(nres))
19647 !(maxres)
19648 !----------------------
19649
19650 !      common /indices/
19651       allocate(ibond_displ(0:nfgtasks-1))
19652       allocate(ibond_count(0:nfgtasks-1))
19653       allocate(ithet_displ(0:nfgtasks-1))
19654       allocate(ithet_count(0:nfgtasks-1))
19655       allocate(iphi_displ(0:nfgtasks-1))
19656       allocate(iphi_count(0:nfgtasks-1))
19657       allocate(iphi1_displ(0:nfgtasks-1))
19658       allocate(iphi1_count(0:nfgtasks-1))
19659       allocate(ivec_displ(0:nfgtasks-1))
19660       allocate(ivec_count(0:nfgtasks-1))
19661       allocate(iset_displ(0:nfgtasks-1))
19662       allocate(iset_count(0:nfgtasks-1))
19663       allocate(iint_count(0:nfgtasks-1))
19664       allocate(iint_displ(0:nfgtasks-1))
19665 !(0:max_fg_procs-1)
19666 !----------------------
19667 ! common.MD
19668 !      common /mdgrad/
19669       allocate(gcart(3,-1:nres))
19670       allocate(gxcart(3,-1:nres))
19671 !(3,0:MAXRES)
19672       allocate(gradcag(3,-1:nres))
19673       allocate(gradxag(3,-1:nres))
19674 !(3,MAXRES)
19675 !      common /back_constr/
19676 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19677       allocate(dutheta(nres))
19678       allocate(dugamma(nres))
19679 !(maxres)
19680       allocate(duscdiff(3,nres))
19681       allocate(duscdiffx(3,nres))
19682 !(3,maxres)
19683 !el i io:read_fragments
19684 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19685 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19686 !      common /qmeas/
19687 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19688 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19689       allocate(mset(0:nprocs))  !(maxprocs/20)
19690       mset(:)=0
19691 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19692 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19693       allocate(dUdconst(3,0:nres))
19694       allocate(dUdxconst(3,0:nres))
19695       allocate(dqwol(3,0:nres))
19696       allocate(dxqwol(3,0:nres))
19697 !(3,0:MAXRES)
19698 !----------------------
19699 ! common.sbridge
19700 !      common /sbridge/ in io_common: read_bridge
19701 !el    allocate((:),allocatable :: iss  !(maxss)
19702 !      common /links/  in io_common: read_bridge
19703 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19704 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19705 !      common /dyn_ssbond/
19706 ! and side-chain vectors in theta or phi.
19707       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19708 !(maxres,maxres)
19709 !      do i=1,nres
19710 !        do j=i+1,nres
19711       dyn_ssbond_ij(:,:)=1.0d300
19712 !        enddo
19713 !      enddo
19714
19715 !      if (nss.gt.0) then
19716         allocate(idssb(maxdim),jdssb(maxdim))
19717 !        allocate(newihpb(nss),newjhpb(nss))
19718 !(maxdim)
19719 !      endif
19720       allocate(ishield_list(nres))
19721       allocate(shield_list(50,nres))
19722       allocate(dyn_ss_mask(nres))
19723       allocate(fac_shield(nres))
19724       allocate(enetube(nres*2))
19725       allocate(enecavtube(nres*2))
19726
19727 !(maxres)
19728       dyn_ss_mask(:)=.false.
19729 !----------------------
19730 ! common.sccor
19731 ! Parameters of the SCCOR term
19732 !      common/sccor/
19733 !el in io_conf: parmread
19734 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
19735 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
19736 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
19737 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
19738 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
19739 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
19740 !      allocate(vlor1sccor(maxterm_sccor,20,20))
19741 !      allocate(vlor2sccor(maxterm_sccor,20,20))
19742 !      allocate(vlor3sccor(maxterm_sccor,20,20))        !(maxterm_sccor,20,20)
19743 !----------------
19744       allocate(gloc_sc(3,0:2*nres,0:10))
19745 !(3,0:maxres2,10)maxres2=2*maxres
19746       allocate(dcostau(3,3,3,2*nres))
19747       allocate(dsintau(3,3,3,2*nres))
19748       allocate(dtauangle(3,3,3,2*nres))
19749       allocate(dcosomicron(3,3,3,2*nres))
19750       allocate(domicron(3,3,3,2*nres))
19751 !(3,3,3,maxres2)maxres2=2*maxres
19752 !----------------------
19753 ! common.var
19754 !      common /restr/
19755       allocate(varall(maxvar))
19756 !(maxvar)(maxvar=6*maxres)
19757       allocate(mask_theta(nres))
19758       allocate(mask_phi(nres))
19759       allocate(mask_side(nres))
19760 !(maxres)
19761 !----------------------
19762 ! common.vectors
19763 !      common /vectors/
19764       allocate(uy(3,nres))
19765       allocate(uz(3,nres))
19766 !(3,maxres)
19767       allocate(uygrad(3,3,2,nres))
19768       allocate(uzgrad(3,3,2,nres))
19769 !(3,3,2,maxres)
19770
19771       return
19772       end subroutine alloc_ener_arrays
19773 !-----------------------------------------------------------------
19774       subroutine ebond_nucl(estr_nucl)
19775 !c
19776 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
19777 !c
19778
19779       real(kind=8),dimension(3) :: u,ud
19780       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
19781       real(kind=8) :: estr_nucl,diff
19782       integer :: iti,i,j,k,nbi
19783       estr_nucl=0.0d0
19784 !C      print *,"I enter ebond"
19785       if (energy_dec) &
19786       write (iout,*) "ibondp_start,ibondp_end",&
19787        ibondp_nucl_start,ibondp_nucl_end
19788       do i=ibondp_nucl_start,ibondp_nucl_end
19789         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
19790          itype(i,2).eq.ntyp1_molec(2)) cycle
19791 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
19792 !          do j=1,3
19793 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
19794 !     &      *dc(j,i-1)/vbld(i)
19795 !          enddo
19796 !          if (energy_dec) write(iout,*)
19797 !     &       "estr1",i,vbld(i),distchainmax,
19798 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
19799
19800           diff = vbld(i)-vbldp0_nucl
19801           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
19802           vbldp0_nucl,diff,AKP_nucl*diff*diff
19803           estr_nucl=estr_nucl+diff*diff
19804           print *,estr_nucl
19805           do j=1,3
19806             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
19807           enddo
19808 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
19809       enddo
19810       estr_nucl=0.5d0*AKP_nucl*estr_nucl
19811       print *,"partial sum", estr_nucl,AKP_nucl
19812
19813       if (energy_dec) &
19814       write (iout,*) "ibondp_start,ibondp_end",&
19815        ibond_nucl_start,ibond_nucl_end
19816
19817       do i=ibond_nucl_start,ibond_nucl_end
19818 !C        print *, "I am stuck",i
19819         iti=itype(i,2)
19820         if (iti.eq.ntyp1_molec(2)) cycle
19821           nbi=nbondterm_nucl(iti)
19822 !C        print *,iti,nbi
19823           if (nbi.eq.1) then
19824             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
19825
19826             if (energy_dec) &
19827            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
19828            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
19829             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
19830             print *,estr_nucl
19831             do j=1,3
19832               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
19833             enddo
19834           else
19835             do j=1,nbi
19836               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
19837               ud(j)=aksc_nucl(j,iti)*diff
19838               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
19839             enddo
19840             uprod=u(1)
19841             do j=2,nbi
19842               uprod=uprod*u(j)
19843             enddo
19844             usum=0.0d0
19845             usumsqder=0.0d0
19846             do j=1,nbi
19847               uprod1=1.0d0
19848               uprod2=1.0d0
19849               do k=1,nbi
19850                 if (k.ne.j) then
19851                   uprod1=uprod1*u(k)
19852                   uprod2=uprod2*u(k)*u(k)
19853                 endif
19854               enddo
19855               usum=usum+uprod1
19856               usumsqder=usumsqder+ud(j)*uprod2
19857             enddo
19858             estr_nucl=estr_nucl+uprod/usum
19859             do j=1,3
19860              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
19861             enddo
19862         endif
19863       enddo
19864 !C      print *,"I am about to leave ebond"
19865       return
19866       end subroutine ebond_nucl
19867
19868 !-----------------------------------------------------------------------------
19869       subroutine ebend_nucl(etheta_nucl)
19870       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
19871       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
19872       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
19873       logical :: lprn=.true., lprn1=.false.
19874 !el local variables
19875       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
19876       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
19877       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
19878 ! local variables for constrains
19879       real(kind=8) :: difi,thetiii
19880        integer itheta
19881       etheta_nucl=0.0D0
19882 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
19883       do i=ithet_nucl_start,ithet_nucl_end
19884         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
19885         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
19886         (itype(i,2).eq.ntyp1_molec(2))) cycle
19887         dethetai=0.0d0
19888         dephii=0.0d0
19889         dephii1=0.0d0
19890         theti2=0.5d0*theta(i)
19891         ityp2=ithetyp_nucl(itype(i-1,2))
19892         do k=1,nntheterm_nucl
19893           coskt(k)=dcos(k*theti2)
19894           sinkt(k)=dsin(k*theti2)
19895         enddo
19896         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
19897 #ifdef OSF
19898           phii=phi(i)
19899           if (phii.ne.phii) phii=150.0
19900 #else
19901           phii=phi(i)
19902 #endif
19903           ityp1=ithetyp_nucl(itype(i-2,2))
19904           do k=1,nsingle_nucl
19905             cosph1(k)=dcos(k*phii)
19906             sinph1(k)=dsin(k*phii)
19907           enddo
19908         else
19909           phii=0.0d0
19910           ityp1=nthetyp_nucl+1
19911           do k=1,nsingle_nucl
19912             cosph1(k)=0.0d0
19913             sinph1(k)=0.0d0
19914           enddo
19915         endif
19916
19917         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
19918 #ifdef OSF
19919           phii1=phi(i+1)
19920           if (phii1.ne.phii1) phii1=150.0
19921           phii1=pinorm(phii1)
19922 #else
19923           phii1=phi(i+1)
19924 #endif
19925           ityp3=ithetyp_nucl(itype(i,2))
19926           do k=1,nsingle_nucl
19927             cosph2(k)=dcos(k*phii1)
19928             sinph2(k)=dsin(k*phii1)
19929           enddo
19930         else
19931           phii1=0.0d0
19932           ityp3=nthetyp_nucl+1
19933           do k=1,nsingle_nucl
19934             cosph2(k)=0.0d0
19935             sinph2(k)=0.0d0
19936           enddo
19937         endif
19938         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
19939         do k=1,ndouble_nucl
19940           do l=1,k-1
19941             ccl=cosph1(l)*cosph2(k-l)
19942             ssl=sinph1(l)*sinph2(k-l)
19943             scl=sinph1(l)*cosph2(k-l)
19944             csl=cosph1(l)*sinph2(k-l)
19945             cosph1ph2(l,k)=ccl-ssl
19946             cosph1ph2(k,l)=ccl+ssl
19947             sinph1ph2(l,k)=scl+csl
19948             sinph1ph2(k,l)=scl-csl
19949           enddo
19950         enddo
19951         if (lprn) then
19952         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
19953          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
19954         write (iout,*) "coskt and sinkt",nntheterm_nucl
19955         do k=1,nntheterm_nucl
19956           write (iout,*) k,coskt(k),sinkt(k)
19957         enddo
19958         endif
19959         do k=1,ntheterm_nucl
19960           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
19961           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
19962            *coskt(k)
19963           if (lprn)&
19964          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
19965           " ethetai",ethetai
19966         enddo
19967         if (lprn) then
19968         write (iout,*) "cosph and sinph"
19969         do k=1,nsingle_nucl
19970           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
19971         enddo
19972         write (iout,*) "cosph1ph2 and sinph2ph2"
19973         do k=2,ndouble_nucl
19974           do l=1,k-1
19975             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
19976               sinph1ph2(l,k),sinph1ph2(k,l)
19977           enddo
19978         enddo
19979         write(iout,*) "ethetai",ethetai
19980         endif
19981         do m=1,ntheterm2_nucl
19982           do k=1,nsingle_nucl
19983             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
19984               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
19985               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
19986               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
19987             ethetai=ethetai+sinkt(m)*aux
19988             dethetai=dethetai+0.5d0*m*aux*coskt(m)
19989             dephii=dephii+k*sinkt(m)*(&
19990                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
19991                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
19992             dephii1=dephii1+k*sinkt(m)*(&
19993                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
19994                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
19995             if (lprn) &
19996            write (iout,*) "m",m," k",k," bbthet",&
19997               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
19998               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
19999               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20000               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20001           enddo
20002         enddo
20003         if (lprn) &
20004         write(iout,*) "ethetai",ethetai
20005         do m=1,ntheterm3_nucl
20006           do k=2,ndouble_nucl
20007             do l=1,k-1
20008               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20009                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20010                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20011                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20012               ethetai=ethetai+sinkt(m)*aux
20013               dethetai=dethetai+0.5d0*m*coskt(m)*aux
20014               dephii=dephii+l*sinkt(m)*(&
20015                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20016                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20017                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20018                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20019               dephii1=dephii1+(k-l)*sinkt(m)*( &
20020                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20021                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20022                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20023                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20024               if (lprn) then
20025               write (iout,*) "m",m," k",k," l",l," ffthet", &
20026                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20027                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20028                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20029                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20030               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20031                  cosph1ph2(k,l)*sinkt(m),&
20032                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20033               endif
20034             enddo
20035           enddo
20036         enddo
20037 10      continue
20038         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20039         i,theta(i)*rad2deg,phii*rad2deg, &
20040         phii1*rad2deg,ethetai
20041         etheta_nucl=etheta_nucl+ethetai
20042 !        print *,i,"partial sum",etheta_nucl
20043         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20044         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20045         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20046       enddo
20047       return
20048       end subroutine ebend_nucl
20049 !----------------------------------------------------
20050       subroutine etor_nucl(etors_nucl)
20051 !      implicit real*8 (a-h,o-z)
20052 !      include 'DIMENSIONS'
20053 !      include 'COMMON.VAR'
20054 !      include 'COMMON.GEO'
20055 !      include 'COMMON.LOCAL'
20056 !      include 'COMMON.TORSION'
20057 !      include 'COMMON.INTERACT'
20058 !      include 'COMMON.DERIV'
20059 !      include 'COMMON.CHAIN'
20060 !      include 'COMMON.NAMES'
20061 !      include 'COMMON.IOUNITS'
20062 !      include 'COMMON.FFIELD'
20063 !      include 'COMMON.TORCNSTR'
20064 !      include 'COMMON.CONTROL'
20065       real(kind=8) :: etors_nucl,edihcnstr
20066       logical :: lprn
20067 !el local variables
20068       integer :: i,j,iblock,itori,itori1
20069       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20070                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20071 ! Set lprn=.true. for debugging
20072       lprn=.false.
20073 !     lprn=.true.
20074       etors_nucl=0.0D0
20075 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20076       do i=iphi_nucl_start,iphi_nucl_end
20077         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20078              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20079              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20080         etors_ii=0.0D0
20081         itori=itortyp_nucl(itype(i-2,2))
20082         itori1=itortyp_nucl(itype(i-1,2))
20083         phii=phi(i)
20084 !         print *,i,itori,itori1
20085         gloci=0.0D0
20086 !C Regular cosine and sine terms
20087         do j=1,nterm_nucl(itori,itori1)
20088           v1ij=v1_nucl(j,itori,itori1)
20089           v2ij=v2_nucl(j,itori,itori1)
20090           cosphi=dcos(j*phii)
20091           sinphi=dsin(j*phii)
20092           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20093           if (energy_dec) etors_ii=etors_ii+&
20094                      v1ij*cosphi+v2ij*sinphi
20095           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20096         enddo
20097 !C Lorentz terms
20098 !C                         v1
20099 !C  E = SUM ----------------------------------- - v1
20100 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20101 !C
20102         cosphi=dcos(0.5d0*phii)
20103         sinphi=dsin(0.5d0*phii)
20104         do j=1,nlor_nucl(itori,itori1)
20105           vl1ij=vlor1_nucl(j,itori,itori1)
20106           vl2ij=vlor2_nucl(j,itori,itori1)
20107           vl3ij=vlor3_nucl(j,itori,itori1)
20108           pom=vl2ij*cosphi+vl3ij*sinphi
20109           pom1=1.0d0/(pom*pom+1.0d0)
20110           etors_nucl=etors_nucl+vl1ij*pom1
20111           if (energy_dec) etors_ii=etors_ii+ &
20112                      vl1ij*pom1
20113           pom=-pom*pom1*pom1
20114           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20115         enddo
20116 !C Subtract the constant term
20117         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20118           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20119               'etor',i,etors_ii-v0_nucl(itori,itori1)
20120         if (lprn) &
20121        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20122        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20123        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20124         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20125 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20126       enddo
20127       return
20128       end subroutine etor_nucl
20129 !------------------------------------------------------------
20130       subroutine epp_nucl_sub(evdw1,ees)
20131 !C
20132 !C This subroutine calculates the average interaction energy and its gradient
20133 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20134 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20135 !C The potential depends both on the distance of peptide-group centers and on
20136 !C the orientation of the CA-CA virtual bonds.
20137 !C
20138       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20139       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
20140       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20141                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20142                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20143       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20144                     dist_temp, dist_init,sss_grad,fac,evdw1ij
20145       integer xshift,yshift,zshift
20146       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20147       real(kind=8) :: ees,eesij
20148 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20149       real(kind=8) scal_el /0.5d0/
20150       t_eelecij=0.0d0
20151       ees=0.0D0
20152       evdw1=0.0D0
20153       ind=0
20154 !c
20155 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20156 !c
20157       print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20158       do i=iatel_s_nucl,iatel_e_nucl
20159         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20160         dxi=dc(1,i)
20161         dyi=dc(2,i)
20162         dzi=dc(3,i)
20163         dx_normi=dc_norm(1,i)
20164         dy_normi=dc_norm(2,i)
20165         dz_normi=dc_norm(3,i)
20166         xmedi=c(1,i)+0.5d0*dxi
20167         ymedi=c(2,i)+0.5d0*dyi
20168         zmedi=c(3,i)+0.5d0*dzi
20169           xmedi=dmod(xmedi,boxxsize)
20170           if (xmedi.lt.0) xmedi=xmedi+boxxsize
20171           ymedi=dmod(ymedi,boxysize)
20172           if (ymedi.lt.0) ymedi=ymedi+boxysize
20173           zmedi=dmod(zmedi,boxzsize)
20174           if (zmedi.lt.0) zmedi=zmedi+boxzsize
20175
20176         do j=ielstart_nucl(i),ielend_nucl(i)
20177           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20178           ind=ind+1
20179           dxj=dc(1,j)
20180           dyj=dc(2,j)
20181           dzj=dc(3,j)
20182 !          xj=c(1,j)+0.5D0*dxj-xmedi
20183 !          yj=c(2,j)+0.5D0*dyj-ymedi
20184 !          zj=c(3,j)+0.5D0*dzj-zmedi
20185           xj=c(1,j)+0.5D0*dxj
20186           yj=c(2,j)+0.5D0*dyj
20187           zj=c(3,j)+0.5D0*dzj
20188           xj=mod(xj,boxxsize)
20189           if (xj.lt.0) xj=xj+boxxsize
20190           yj=mod(yj,boxysize)
20191           if (yj.lt.0) yj=yj+boxysize
20192           zj=mod(zj,boxzsize)
20193           if (zj.lt.0) zj=zj+boxzsize
20194       isubchap=0
20195       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20196       xj_safe=xj
20197       yj_safe=yj
20198       zj_safe=zj
20199       do xshift=-1,1
20200       do yshift=-1,1
20201       do zshift=-1,1
20202           xj=xj_safe+xshift*boxxsize
20203           yj=yj_safe+yshift*boxysize
20204           zj=zj_safe+zshift*boxzsize
20205           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20206           if(dist_temp.lt.dist_init) then
20207             dist_init=dist_temp
20208             xj_temp=xj
20209             yj_temp=yj
20210             zj_temp=zj
20211             isubchap=1
20212           endif
20213        enddo
20214        enddo
20215        enddo
20216        if (isubchap.eq.1) then
20217 !C          print *,i,j
20218           xj=xj_temp-xmedi
20219           yj=yj_temp-ymedi
20220           zj=zj_temp-zmedi
20221        else
20222           xj=xj_safe-xmedi
20223           yj=yj_safe-ymedi
20224           zj=zj_safe-zmedi
20225        endif
20226
20227           rij=xj*xj+yj*yj+zj*zj
20228 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20229           fac=(r0pp**2/rij)**3
20230           ev1=epspp*fac*fac
20231           ev2=epspp*fac
20232           evdw1ij=ev1-2*ev2
20233           fac=(-ev1-evdw1ij)/rij
20234 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20235           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20236           evdw1=evdw1+evdw1ij
20237 !C
20238 !C Calculate contributions to the Cartesian gradient.
20239 !C
20240           ggg(1)=fac*xj
20241           ggg(2)=fac*yj
20242           ggg(3)=fac*zj
20243           do k=1,3
20244             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
20245             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
20246           enddo
20247 !c phoshate-phosphate electrostatic interactions
20248           rij=dsqrt(rij)
20249           fac=1.0d0/rij
20250           eesij=dexp(-BEES*rij)*fac
20251 !          write (2,*)"fac",fac," eesijpp",eesij
20252           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
20253           ees=ees+eesij
20254 !c          fac=-eesij*fac
20255           fac=-(fac+BEES)*eesij*fac
20256           ggg(1)=fac*xj
20257           ggg(2)=fac*yj
20258           ggg(3)=fac*zj
20259 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
20260 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
20261 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
20262           do k=1,3
20263             gelpp(k,i)=gelpp(k,i)-ggg(k)
20264             gelpp(k,j)=gelpp(k,j)+ggg(k)
20265           enddo
20266         enddo ! j
20267       enddo   ! i
20268 !c      ees=332.0d0*ees
20269       ees=AEES*ees
20270       do i=nnt,nct
20271 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20272         do k=1,3
20273           gvdwpp(k,i)=6*gvdwpp(k,i)
20274 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
20275           gelpp(k,i)=AEES*gelpp(k,i)
20276         enddo
20277 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20278       enddo
20279 !c      write (2,*) "total EES",ees
20280       return
20281       end subroutine epp_nucl_sub
20282 !---------------------------------------------------------------------
20283       subroutine epsb(evdwpsb,eelpsb)
20284 !      use comm_locel
20285 !C
20286 !C This subroutine calculates the excluded-volume interaction energy between
20287 !C peptide-group centers and side chains and its gradient in virtual-bond and
20288 !C side-chain vectors.
20289 !C
20290       real(kind=8),dimension(3):: ggg
20291       integer :: i,iint,j,k,iteli,itypj,subchap
20292       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
20293                    e1,e2,evdwij,rij,evdwpsb,eelpsb
20294       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20295                     dist_temp, dist_init
20296       integer xshift,yshift,zshift
20297
20298 !cd    print '(a)','Enter ESCP'
20299 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
20300       eelpsb=0.0d0
20301       evdwpsb=0.0d0
20302       print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
20303       do i=iatscp_s_nucl,iatscp_e_nucl
20304         if (itype(i,2).eq.ntyp1_molec(2) &
20305          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20306         xi=0.5D0*(c(1,i)+c(1,i+1))
20307         yi=0.5D0*(c(2,i)+c(2,i+1))
20308         zi=0.5D0*(c(3,i)+c(3,i+1))
20309           xi=mod(xi,boxxsize)
20310           if (xi.lt.0) xi=xi+boxxsize
20311           yi=mod(yi,boxysize)
20312           if (yi.lt.0) yi=yi+boxysize
20313           zi=mod(zi,boxzsize)
20314           if (zi.lt.0) zi=zi+boxzsize
20315
20316         do iint=1,nscp_gr_nucl(i)
20317
20318         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
20319           itypj=itype(j,2)
20320           if (itypj.eq.ntyp1_molec(2)) cycle
20321 !C Uncomment following three lines for SC-p interactions
20322 !c         xj=c(1,nres+j)-xi
20323 !c         yj=c(2,nres+j)-yi
20324 !c         zj=c(3,nres+j)-zi
20325 !C Uncomment following three lines for Ca-p interactions
20326 !          xj=c(1,j)-xi
20327 !          yj=c(2,j)-yi
20328 !          zj=c(3,j)-zi
20329           xj=c(1,j)
20330           yj=c(2,j)
20331           zj=c(3,j)
20332           xj=mod(xj,boxxsize)
20333           if (xj.lt.0) xj=xj+boxxsize
20334           yj=mod(yj,boxysize)
20335           if (yj.lt.0) yj=yj+boxysize
20336           zj=mod(zj,boxzsize)
20337           if (zj.lt.0) zj=zj+boxzsize
20338       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20339       xj_safe=xj
20340       yj_safe=yj
20341       zj_safe=zj
20342       subchap=0
20343       do xshift=-1,1
20344       do yshift=-1,1
20345       do zshift=-1,1
20346           xj=xj_safe+xshift*boxxsize
20347           yj=yj_safe+yshift*boxysize
20348           zj=zj_safe+zshift*boxzsize
20349           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20350           if(dist_temp.lt.dist_init) then
20351             dist_init=dist_temp
20352             xj_temp=xj
20353             yj_temp=yj
20354             zj_temp=zj
20355             subchap=1
20356           endif
20357        enddo
20358        enddo
20359        enddo
20360        if (subchap.eq.1) then
20361           xj=xj_temp-xi
20362           yj=yj_temp-yi
20363           zj=zj_temp-zi
20364        else
20365           xj=xj_safe-xi
20366           yj=yj_safe-yi
20367           zj=zj_safe-zi
20368        endif
20369
20370           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20371           fac=rrij**expon2
20372           e1=fac*fac*aad_nucl(itypj)
20373           e2=fac*bad_nucl(itypj)
20374           if (iabs(j-i) .le. 2) then
20375             e1=scal14*e1
20376             e2=scal14*e2
20377           endif
20378           evdwij=e1+e2
20379           evdwpsb=evdwpsb+evdwij
20380           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
20381              'evdw2',i,j,evdwij,"tu4"
20382 !C
20383 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
20384 !C
20385           fac=-(evdwij+e1)*rrij
20386           ggg(1)=xj*fac
20387           ggg(2)=yj*fac
20388           ggg(3)=zj*fac
20389           do k=1,3
20390             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
20391             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
20392           enddo
20393         enddo
20394
20395         enddo ! iint
20396       enddo ! i
20397       do i=1,nct
20398         do j=1,3
20399           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
20400           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
20401         enddo
20402       enddo
20403       return
20404       end subroutine epsb
20405
20406 !------------------------------------------------------
20407       subroutine esb_gb(evdwsb,eelsb)
20408       use comm_locel
20409       use calc_data_nucl
20410       integer :: iint,itypi,itypi1,itypj,subchap
20411       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
20412       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
20413       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20414                     dist_temp, dist_init,aa,bb,faclip,sig0ij
20415       integer :: ii
20416       logical lprn
20417       evdw=0.0D0
20418       eelsb=0.0d0
20419       ecorr=0.0d0
20420       evdwsb=0.0D0
20421       lprn=.false.
20422       ind=0
20423 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
20424       do i=iatsc_s_nucl,iatsc_e_nucl
20425         num_conti=0
20426         itypi=itype(i,2)
20427 !        PRINT *,"I=",i,itypi
20428         if (itypi.eq.ntyp1_molec(2)) cycle
20429         itypi1=itype(i+1,2)
20430         xi=c(1,nres+i)
20431         yi=c(2,nres+i)
20432         zi=c(3,nres+i)
20433           xi=dmod(xi,boxxsize)
20434           if (xi.lt.0) xi=xi+boxxsize
20435           yi=dmod(yi,boxysize)
20436           if (yi.lt.0) yi=yi+boxysize
20437           zi=dmod(zi,boxzsize)
20438           if (zi.lt.0) zi=zi+boxzsize
20439
20440         dxi=dc_norm(1,nres+i)
20441         dyi=dc_norm(2,nres+i)
20442         dzi=dc_norm(3,nres+i)
20443         dsci_inv=vbld_inv(i+nres)
20444 !C
20445 !C Calculate SC interaction energy.
20446 !C
20447         do iint=1,nint_gr_nucl(i)
20448 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
20449           do j=istart_nucl(i,iint),iend_nucl(i,iint)
20450             ind=ind+1
20451 !            print *,"JESTEM"
20452             itypj=itype(j,2)
20453             if (itypj.eq.ntyp1_molec(2)) cycle
20454             dscj_inv=vbld_inv(j+nres)
20455             sig0ij=sigma_nucl(itypi,itypj)
20456             chi1=chi_nucl(itypi,itypj)
20457             chi2=chi_nucl(itypj,itypi)
20458             chi12=chi1*chi2
20459             chip1=chip_nucl(itypi,itypj)
20460             chip2=chip_nucl(itypj,itypi)
20461             chip12=chip1*chip2
20462 !            xj=c(1,nres+j)-xi
20463 !            yj=c(2,nres+j)-yi
20464 !            zj=c(3,nres+j)-zi
20465            xj=c(1,nres+j)
20466            yj=c(2,nres+j)
20467            zj=c(3,nres+j)
20468           xj=dmod(xj,boxxsize)
20469           if (xj.lt.0) xj=xj+boxxsize
20470           yj=dmod(yj,boxysize)
20471           if (yj.lt.0) yj=yj+boxysize
20472           zj=dmod(zj,boxzsize)
20473           if (zj.lt.0) zj=zj+boxzsize
20474       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20475       xj_safe=xj
20476       yj_safe=yj
20477       zj_safe=zj
20478       subchap=0
20479       do xshift=-1,1
20480       do yshift=-1,1
20481       do zshift=-1,1
20482           xj=xj_safe+xshift*boxxsize
20483           yj=yj_safe+yshift*boxysize
20484           zj=zj_safe+zshift*boxzsize
20485           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20486           if(dist_temp.lt.dist_init) then
20487             dist_init=dist_temp
20488             xj_temp=xj
20489             yj_temp=yj
20490             zj_temp=zj
20491             subchap=1
20492           endif
20493        enddo
20494        enddo
20495        enddo
20496        if (subchap.eq.1) then
20497           xj=xj_temp-xi
20498           yj=yj_temp-yi
20499           zj=zj_temp-zi
20500        else
20501           xj=xj_safe-xi
20502           yj=yj_safe-yi
20503           zj=zj_safe-zi
20504        endif
20505
20506             dxj=dc_norm(1,nres+j)
20507             dyj=dc_norm(2,nres+j)
20508             dzj=dc_norm(3,nres+j)
20509             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20510             rij=dsqrt(rrij)
20511 !C Calculate angle-dependent terms of energy and contributions to their
20512 !C derivatives.
20513             erij(1)=xj*rij
20514             erij(2)=yj*rij
20515             erij(3)=zj*rij
20516             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
20517             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
20518             om12=dxi*dxj+dyi*dyj+dzi*dzj
20519             call sc_angular_nucl
20520             sigsq=1.0D0/sigsq
20521             sig=sig0ij*dsqrt(sigsq)
20522             rij_shift=1.0D0/rij-sig+sig0ij
20523 !            print *,rij_shift,"rij_shift"
20524 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
20525 !c     &       " rij_shift",rij_shift
20526             if (rij_shift.le.0.0D0) then
20527               evdw=1.0D20
20528               return
20529             endif
20530             sigder=-sig*sigsq
20531 !c---------------------------------------------------------------
20532             rij_shift=1.0D0/rij_shift
20533             fac=rij_shift**expon
20534             e1=fac*fac*aa_nucl(itypi,itypj)
20535             e2=fac*bb_nucl(itypi,itypj)
20536             evdwij=eps1*eps2rt*(e1+e2)
20537 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
20538 !c     &       " e1",e1," e2",e2," evdwij",evdwij
20539             eps2der=evdwij
20540             evdwij=evdwij*eps2rt
20541             evdwsb=evdwsb+evdwij
20542             if (lprn) then
20543             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
20544             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
20545             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
20546              restyp(itypi,2),i,restyp(itypj,2),j, &
20547              epsi,sigm,chi1,chi2,chip1,chip2, &
20548              eps1,eps2rt**2,sig,sig0ij, &
20549              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
20550             evdwij
20551             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
20552             endif
20553
20554             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
20555                              'evdw',i,j,evdwij,"tu3"
20556
20557
20558 !C Calculate gradient components.
20559             e1=e1*eps1*eps2rt**2
20560             fac=-expon*(e1+evdwij)*rij_shift
20561             sigder=fac*sigder
20562             fac=rij*fac
20563 !c            fac=0.0d0
20564 !C Calculate the radial part of the gradient
20565             gg(1)=xj*fac
20566             gg(2)=yj*fac
20567             gg(3)=zj*fac
20568 !C Calculate angular part of the gradient.
20569             call sc_grad_nucl
20570             call eelsbij(eelij)
20571             if (energy_dec .and. &
20572            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
20573           write (istat,'(e14.5)') evdwij
20574             eelsb=eelsb+eelij
20575           enddo      ! j
20576         enddo        ! iint
20577         num_cont_hb(i)=num_conti
20578       enddo          ! i
20579 !c      write (iout,*) "Number of loop steps in EGB:",ind
20580 !cccc      energy_dec=.false.
20581       return
20582       end subroutine esb_gb
20583 !-------------------------------------------------------------------------------
20584       subroutine eelsbij(eesij)
20585       use comm_locel
20586       use calc_data_nucl
20587       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
20588       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
20589       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20590                     dist_temp, dist_init,rlocshield,fracinbuf
20591       integer xshift,yshift,zshift,ilist,iresshield
20592
20593 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20594       real(kind=8) scal_el /0.5d0/
20595       integer :: iteli,itelj,kkk,kkll,m,isubchap
20596       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
20597       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
20598       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
20599                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
20600                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
20601                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
20602                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
20603                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
20604                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
20605                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
20606       ind=ind+1
20607       itypi=itype(i,2)
20608       itypj=itype(j,2)
20609 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
20610       ael6i=ael6_nucl(itypi,itypj)
20611       ael3i=ael3_nucl(itypi,itypj)
20612       ael63i=ael63_nucl(itypi,itypj)
20613       ael32i=ael32_nucl(itypi,itypj)
20614 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
20615 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
20616       dxj=dc(1,j+nres)
20617       dyj=dc(2,j+nres)
20618       dzj=dc(3,j+nres)
20619       dx_normi=dc_norm(1,i+nres)
20620       dy_normi=dc_norm(2,i+nres)
20621       dz_normi=dc_norm(3,i+nres)
20622       dx_normj=dc_norm(1,j+nres)
20623       dy_normj=dc_norm(2,j+nres)
20624       dz_normj=dc_norm(3,j+nres)
20625 !c      xj=c(1,j)+0.5D0*dxj-xmedi
20626 !c      yj=c(2,j)+0.5D0*dyj-ymedi
20627 !c      zj=c(3,j)+0.5D0*dzj-zmedi
20628       if (ipot_nucl.ne.2) then
20629         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
20630         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
20631         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
20632       else
20633         cosa=om12
20634         cosb=om1
20635         cosg=om2
20636       endif
20637       r3ij=rij*rrij
20638       r6ij=r3ij*r3ij
20639       fac=cosa-3.0D0*cosb*cosg
20640       facfac=fac*fac
20641       fac1=3.0d0*(cosb*cosb+cosg*cosg)
20642       fac3=ael6i*r6ij
20643       fac4=ael3i*r3ij
20644       fac5=ael63i*r6ij
20645       fac6=ael32i*r6ij
20646 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
20647 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
20648       el1=fac3*(4.0D0+facfac-fac1)
20649       el2=fac4*fac
20650       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
20651       el4=fac6*facfac
20652       eesij=el1+el2+el3+el4
20653 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
20654       ees0ij=4.0D0+facfac-fac1
20655
20656       if (energy_dec) then
20657           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
20658           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
20659            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
20660            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
20661            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
20662           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
20663       endif
20664
20665 !C
20666 !C Calculate contributions to the Cartesian gradient.
20667 !C
20668       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
20669       fac1=fac
20670 !c      erij(1)=xj*rmij
20671 !c      erij(2)=yj*rmij
20672 !c      erij(3)=zj*rmij
20673 !*
20674 !* Radial derivatives. First process both termini of the fragment (i,j)
20675 !*
20676       ggg(1)=facel*xj
20677       ggg(2)=facel*yj
20678       ggg(3)=facel*zj
20679       do k=1,3
20680         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20681         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20682         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
20683         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
20684       enddo
20685 !*
20686 !* Angular part
20687 !*
20688       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
20689       fac4=-3.0D0*fac4
20690       fac3=-6.0D0*fac3
20691       fac5= 6.0d0*fac5
20692       fac6=-6.0d0*fac6
20693       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
20694        fac6*fac1*cosg
20695       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
20696        fac6*fac1*cosb
20697       do k=1,3
20698         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
20699         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
20700       enddo
20701       do k=1,3
20702         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
20703       enddo
20704       do k=1,3
20705         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
20706              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
20707              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20708         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
20709              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
20710              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20711         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20712         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20713       enddo
20714       IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and. j.gt.i+1 .and.&
20715           num_conti.le.maxconts) THEN
20716 !C
20717 !C Calculate the contact function. The ith column of the array JCONT will
20718 !C contain the numbers of atoms that make contacts with the atom I (of numbers
20719 !C greater than I). The arrays FACONT and GACONT will contain the values of
20720 !C the contact function and its derivative.
20721         r0ij=2.20D0*sigma(itypi,itypj)
20722 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
20723         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
20724 !c        write (2,*) "fcont",fcont
20725         if (fcont.gt.0.0D0) then
20726           num_conti=num_conti+1
20727           if (num_conti.gt.maxconts) then
20728             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
20729                           ' will skip next contacts for this conf.'
20730           else
20731             jcont_hb(num_conti,i)=j
20732 !c            write (iout,*) "num_conti",num_conti,
20733 !c     &        " jcont_hb",jcont_hb(num_conti,i)
20734 !C Calculate contact energies
20735             cosa4=4.0D0*cosa
20736             wij=cosa-3.0D0*cosb*cosg
20737             cosbg1=cosb+cosg
20738             cosbg2=cosb-cosg
20739             fac3=dsqrt(-ael6i)*r3ij
20740 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
20741             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
20742             if (ees0tmp.gt.0) then
20743               ees0pij=dsqrt(ees0tmp)
20744             else
20745               ees0pij=0
20746             endif
20747             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
20748             if (ees0tmp.gt.0) then
20749               ees0mij=dsqrt(ees0tmp)
20750             else
20751               ees0mij=0
20752             endif
20753             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
20754             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
20755 !c            write (iout,*) "i",i," j",j,
20756 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
20757             ees0pij1=fac3/ees0pij
20758             ees0mij1=fac3/ees0mij
20759             fac3p=-3.0D0*fac3*rrij
20760             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
20761             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
20762             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
20763             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
20764             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
20765             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
20766             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
20767             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
20768             ecosap=ecosa1+ecosa2
20769             ecosbp=ecosb1+ecosb2
20770             ecosgp=ecosg1+ecosg2
20771             ecosam=ecosa1-ecosa2
20772             ecosbm=ecosb1-ecosb2
20773             ecosgm=ecosg1-ecosg2
20774 !C End diagnostics
20775             facont_hb(num_conti,i)=fcont
20776             fprimcont=fprimcont/rij
20777             do k=1,3
20778               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
20779               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
20780             enddo
20781             gggp(1)=gggp(1)+ees0pijp*xj
20782             gggp(2)=gggp(2)+ees0pijp*yj
20783             gggp(3)=gggp(3)+ees0pijp*zj
20784             gggm(1)=gggm(1)+ees0mijp*xj
20785             gggm(2)=gggm(2)+ees0mijp*yj
20786             gggm(3)=gggm(3)+ees0mijp*zj
20787 !C Derivatives due to the contact function
20788             gacont_hbr(1,num_conti,i)=fprimcont*xj
20789             gacont_hbr(2,num_conti,i)=fprimcont*yj
20790             gacont_hbr(3,num_conti,i)=fprimcont*zj
20791             do k=1,3
20792 !c
20793 !c Gradient of the correlation terms
20794 !c
20795               gacontp_hb1(k,num_conti,i)= &
20796              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
20797             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20798               gacontp_hb2(k,num_conti,i)= &
20799              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
20800             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20801               gacontp_hb3(k,num_conti,i)=gggp(k)
20802               gacontm_hb1(k,num_conti,i)= &
20803              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
20804             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20805               gacontm_hb2(k,num_conti,i)= &
20806              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
20807             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20808               gacontm_hb3(k,num_conti,i)=gggm(k)
20809             enddo
20810           endif
20811         endif
20812       ENDIF
20813       return
20814       end subroutine eelsbij
20815 !------------------------------------------------------------------
20816       subroutine sc_grad_nucl
20817       use comm_locel
20818       use calc_data_nucl
20819       real(kind=8),dimension(3) :: dcosom1,dcosom2
20820       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
20821       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
20822       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
20823       do k=1,3
20824         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
20825         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
20826       enddo
20827       do k=1,3
20828         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
20829       enddo
20830       do k=1,3
20831         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
20832                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
20833                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
20834         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
20835                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
20836                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
20837       enddo
20838 !C
20839 !C Calculate the components of the gradient in DC and X
20840 !C
20841       do l=1,3
20842         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
20843         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
20844       enddo
20845       return
20846       end subroutine sc_grad_nucl
20847
20848 !----------------------------------------------------------------------------
20849 !-----------------------------------------------------------------------------
20850 !-----------------------------------------------------------------------------
20851       end module energy