source/unres/src-HCD-5D/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit none
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13       double precision time00
  14       integer ierror,ierr
  15 #endif
  16       include 'COMMON.SETUP'
  17       include 'COMMON.IOUNITS'
  18       double precision energia(0:n_ene)
  19       include 'COMMON.LOCAL'
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.VAR'
  26 c      include 'COMMON.MD'
  27       include 'COMMON.QRESTR'
  28       include 'COMMON.CONTROL'
  29       include 'COMMON.TIME1'
  30       include 'COMMON.SPLITELE'
  31       include 'COMMON.TORCNSTR'
  32       include 'COMMON.SAXS'
  33       include 'COMMON.MD'
  34       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
  35      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
  36      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
  37      & eliptran,Eafmforce,Etube,
  38      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
  39       integer n_corr,n_corr1
  40 #ifdef MPI
  41 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  42 c     & " nfgtasks",nfgtasks
  43       if (nfgtasks.gt.1) then
  44         time00=MPI_Wtime()
  45 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  46         if (fg_rank.eq.0) then
  47           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  48 c          print *,"Processor",myrank," BROADCAST iorder"
  49 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  50 C FG slaves as WEIGHTS array.
  51           weights_(1)=wsc
  52           weights_(2)=wscp
  53           weights_(3)=welec
  54           weights_(4)=wcorr
  55           weights_(5)=wcorr5
  56           weights_(6)=wcorr6
  57           weights_(7)=wel_loc
  58           weights_(8)=wturn3
  59           weights_(9)=wturn4
  60           weights_(10)=wturn6
  61           weights_(11)=wang
  62           weights_(12)=wscloc
  63           weights_(13)=wtor
  64           weights_(14)=wtor_d
  65           weights_(15)=wstrain
  66           weights_(16)=wvdwpp
  67           weights_(17)=wbond
  68           weights_(18)=scal14
  69           weights_(21)=wsccor
  70           weights_(22)=wliptran
  71           weights_(25)=wtube
  72           weights_(26)=wsaxs
  73           weights_(28)=wdfa_dist
  74           weights_(29)=wdfa_tor
  75           weights_(30)=wdfa_nei
  76           weights_(31)=wdfa_beta
  77 C FG Master broadcasts the WEIGHTS_ array
  78           call MPI_Bcast(weights_(1),n_ene,
  79      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  80         else
  81 C FG slaves receive the WEIGHTS array
  82           call MPI_Bcast(weights(1),n_ene,
  83      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  84           wsc=weights(1)
  85           wscp=weights(2)
  86           welec=weights(3)
  87           wcorr=weights(4)
  88           wcorr5=weights(5)
  89           wcorr6=weights(6)
  90           wel_loc=weights(7)
  91           wturn3=weights(8)
  92           wturn4=weights(9)
  93           wturn6=weights(10)
  94           wang=weights(11)
  95           wscloc=weights(12)
  96           wtor=weights(13)
  97           wtor_d=weights(14)
  98           wstrain=weights(15)
  99           wvdwpp=weights(16)
 100           wbond=weights(17)
 101           scal14=weights(18)
 102           wsccor=weights(21)
 103           wliptran=weights(22)
 104           wtube=weights(25)
 105           wsaxs=weights(26)
 106           wdfa_dist=weights(28)
 107           wdfa_tor=weights(29)
 108           wdfa_nei=weights(30)
 109           wdfa_beta=weights(31)
 110         endif
 111         time_Bcast=time_Bcast+MPI_Wtime()-time00
 112         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 113 c        call chainbuild_cart
 114       endif
 115       if (nfgtasks.gt.1) then
 116         call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
 117       endif
 118 c      write (iout,*) "itime_mat",itime_mat," imatupdate",imatupdate
 119       if (mod(itime_mat,imatupdate).eq.0) then
 120         call make_SCp_inter_list
 121 c        write (iout,*) "Finished make_SCp_inter_list"
 122 c        call flush(iout)
 123         call make_SCSC_inter_list
 124 c        write (iout,*) "Finished make_SCSC_inter_list"
 125 c        call flush(iout)
 126         call make_pp_inter_list
 127 c        write (iout,*) "Finished make_pp_inter_list"
 128 c        call flush(iout)
 129         call make_pp_vdw_inter_list
 130 c        write (iout,*) "Finished make_pp_vdw_inter_list"
 131 c        call flush(iout)
 132       endif
 133 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 134 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 135 #else
 136 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 137 c        call int_from_cart1(.false.)
 138 c      endif
 139 #endif
 140 #ifdef TIMING
 141       time00=MPI_Wtime()
 142 #endif
 143
 144 #ifndef DFA
 145       edfadis=0.0d0
 146       edfator=0.0d0
 147       edfanei=0.0d0
 148       edfabet=0.0d0
 149 #endif
 150 C
 151 C Compute the side-chain and electrostatic interaction energy
 152 C
 153 C      print *,ipot
 154       goto (101,102,103,104,105,106) ipot
 155 C Lennard-Jones potential.
 156   101 call elj(evdw)
 157 cd    print '(a)','Exit ELJ'
 158       goto 107
 159 C Lennard-Jones-Kihara potential (shifted).
 160   102 call eljk(evdw)
 161       goto 107
 162 C Berne-Pechukas potential (dilated LJ, angular dependence).
 163   103 call ebp(evdw)
 164       goto 107
 165 C Gay-Berne potential (shifted LJ, angular dependence).
 166   104 call egb(evdw)
 167 C      print *,"bylem w egb"
 168       goto 107
 169 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 170   105 call egbv(evdw)
 171       goto 107
 172 C Soft-sphere potential
 173   106 call e_softsphere(evdw)
 174 C
 175 C Calculate electrostatic (H-bonding) energy of the main chain.
 176 C
 177   107 continue
 178 #ifdef DFA
 179 C     BARTEK for dfa test!
 180 c      print *,"Processors",MyRank," wdfa",wdfa_dist
 181       if (wdfa_dist.gt.0) then
 182         call edfad(edfadis)
 183 c        print *,"Processors",MyRank," edfadis",edfadis
 184       else
 185         edfadis=0
 186       endif
 187 c      print*, 'edfad is finished!', edfadis
 188       if (wdfa_tor.gt.0) then
 189         call edfat(edfator)
 190       else
 191         edfator=0
 192       endif
 193 c      print*, 'edfat is finished!', edfator
 194       if (wdfa_nei.gt.0) then
 195         call edfan(edfanei)
 196       else
 197         edfanei=0
 198       endif
 199 c      print*, 'edfan is finished!', edfanei
 200       if (wdfa_beta.gt.0) then
 201         call edfab(edfabet)
 202       else
 203         edfabet=0
 204       endif
 205 #endif
 206 cmc
 207 cmc Sep-06: egb takes care of dynamic ss bonds too
 208 cmc
 209 c      if (dyn_ss) call dyn_set_nss
 210
 211 c      print *,"Processor",myrank," computed USCSC"
 212 #ifdef TIMING
 213       time01=MPI_Wtime()
 214 #endif
 215       call vec_and_deriv
 216 #ifdef TIMING
 217       time_vec=time_vec+MPI_Wtime()-time01
 218 #endif
 219 C Introduction of shielding effect first for each peptide group
 220 C the shielding factor is set this factor is describing how each
 221 C peptide group is shielded by side-chains
 222 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 223 C      write (iout,*) "shield_mode",shield_mode
 224       if (shield_mode.eq.1) then
 225        call set_shield_fac
 226       else if  (shield_mode.eq.2) then
 227        call set_shield_fac2
 228       endif
 229 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 230       if (ipot.lt.6) then
 231 #ifdef SPLITELE
 232          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 233      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 234      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 235      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 236 #else
 237          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 238      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 239      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 240      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 241 #endif
 242             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 243          else
 244             ees=0.0d0
 245             evdw1=0.0d0
 246             eel_loc=0.0d0
 247             eello_turn3=0.0d0
 248             eello_turn4=0.0d0
 249          endif
 250       else
 251         write (iout,*) "Soft-spheer ELEC potential"
 252 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 253 c     &   eello_turn4)
 254       endif
 255 c#ifdef TIMING
 256 c      time_enecalc=time_enecalc+MPI_Wtime()-time00
 257 c#endif
 258 c      print *,"Processor",myrank," computed UELEC"
 259 C
 260 C Calculate excluded-volume interaction energy between peptide groups
 261 C and side chains.
 262 C
 263       if (ipot.lt.6) then
 264        if(wscp.gt.0d0) then
 265         call escp(evdw2,evdw2_14)
 266        else
 267         evdw2=0
 268         evdw2_14=0
 269        endif
 270       else
 271 c        write (iout,*) "Soft-sphere SCP potential"
 272         call escp_soft_sphere(evdw2,evdw2_14)
 273       endif
 274 c
 275 c Calculate the bond-stretching energy
 276 c
 277       call ebond(estr)
 278 C
 279 C Calculate the disulfide-bridge and other energy and the contributions
 280 C from other distance constraints.
 281 cd      write (iout,*) 'Calling EHPB'
 282       call edis(ehpb)
 283 cd    print *,'EHPB exitted succesfully.'
 284 C
 285 C Calculate the virtual-bond-angle energy.
 286 C
 287       if (wang.gt.0d0) then
 288        if (tor_mode.eq.0) then
 289          call ebend(ebe)
 290        else
 291 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 292 C energy function
 293          call ebend_kcc(ebe)
 294        endif
 295       else
 296         ebe=0.0d0
 297       endif
 298       ethetacnstr=0.0d0
 299       if (with_theta_constr) call etheta_constr(ethetacnstr)
 300 c      print *,"Processor",myrank," computed UB"
 301 C
 302 C Calculate the SC local energy.
 303 C
 304 C      print *,"TU DOCHODZE?"
 305       call esc(escloc)
 306 c      print *,"Processor",myrank," computed USC"
 307 C
 308 C Calculate the virtual-bond torsional energy.
 309 C
 310 cd    print *,'nterm=',nterm
 311 C      print *,"tor",tor_mode
 312       if (wtor.gt.0.0d0) then
 313          if (tor_mode.eq.0) then
 314            call etor(etors)
 315          else
 316 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 317 C energy function
 318            call etor_kcc(etors)
 319          endif
 320       else
 321         etors=0.0d0
 322       endif
 323       edihcnstr=0.0d0
 324       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 325 c      print *,"Processor",myrank," computed Utor"
 326       if (constr_homology.ge.1) then
 327         call e_modeller(ehomology_constr)
 328 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 329 c     &  'Processor',fg_rank,' CG group',kolor,
 330 c     &  ' absolute rank',MyRank
 331       else
 332         ehomology_constr=0.0d0
 333       endif
 334 C
 335 C 6/23/01 Calculate double-torsional energy
 336 C
 337       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 338         call etor_d(etors_d)
 339       else
 340         etors_d=0
 341       endif
 342 c      print *,"Processor",myrank," computed Utord"
 343 C
 344 C 21/5/07 Calculate local sicdechain correlation energy
 345 C
 346       if (wsccor.gt.0.0d0) then
 347         call eback_sc_corr(esccor)
 348       else
 349         esccor=0.0d0
 350       endif
 351 #ifdef FOURBODY
 352 C      print *,"PRZED MULIt"
 353 c      print *,"Processor",myrank," computed Usccorr"
 354 C
 355 C 12/1/95 Multi-body terms
 356 C
 357       n_corr=0
 358       n_corr1=0
 359       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 360      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 361          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 362 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 363 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 364 c        call flush(iout)
 365       else
 366          ecorr=0.0d0
 367          ecorr5=0.0d0
 368          ecorr6=0.0d0
 369          eturn6=0.0d0
 370       endif
 371       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 372 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 373 c     &     n_corr,n_corr1
 374 c         call flush(iout)
 375          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 376 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 377 c     &     n_corr1
 378 c         call flush(iout)
 379       else
 380          ecorr=0.0d0
 381          ecorr5=0.0d0
 382          ecorr6=0.0d0
 383          eturn6=0.0d0
 384       endif
 385 #else
 386       ecorr=0.0d0
 387       ecorr5=0.0d0
 388       ecorr6=0.0d0
 389       eturn6=0.0d0
 390 #endif
 391 c      print *,"Processor",myrank," computed Ucorr"
 392 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 393       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 394         call e_saxs(Esaxs_constr)
 395 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 396       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 397         call e_saxsC(Esaxs_constr)
 398 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 399       else
 400         Esaxs_constr = 0.0d0
 401       endif
 402 C
 403 C If performing constraint dynamics, call the constraint energy
 404 C  after the equilibration time
 405 c      if(usampl.and.totT.gt.eq_time) then
 406 c      write (iout,*) "usampl",usampl
 407       if(usampl) then
 408          call EconstrQ
 409          if (loc_qlike) then
 410            call Econstr_back_qlike
 411          else
 412            call Econstr_back
 413          endif
 414       else
 415          Uconst=0.0d0
 416          Uconst_back=0.0d0
 417       endif
 418 C 01/27/2015 added by adasko
 419 C the energy component below is energy transfer into lipid environment
 420 C based on partition function
 421 C      print *,"przed lipidami"
 422       if (wliptran.gt.0) then
 423         call Eliptransfer(eliptran)
 424       else
 425         eliptran=0.0d0
 426       endif
 427 C      print *,"za lipidami"
 428       if (AFMlog.gt.0) then
 429         call AFMforce(Eafmforce)
 430       else if (selfguide.gt.0) then
 431         call AFMvel(Eafmforce)
 432       else
 433         Eafmforce=0.0d0
 434       endif
 435       if (TUBElog.eq.1) then
 436 C      print *,"just before call"
 437         call calctube(Etube)
 438       elseif (TUBElog.eq.2) then
 439         call calctube2(Etube)
 440       else
 441         Etube=0.0d0
 442       endif
 443
 444 #ifdef TIMING
 445       time_enecalc=time_enecalc+MPI_Wtime()-time00
 446 #endif
 447 c      print *,"Processor",myrank," computed Uconstr"
 448 #ifdef TIMING
 449       time00=MPI_Wtime()
 450 #endif
 451 c
 452 C Sum the energies
 453 C
 454       energia(1)=evdw
 455 #ifdef SCP14
 456       energia(2)=evdw2-evdw2_14
 457       energia(18)=evdw2_14
 458 #else
 459       energia(2)=evdw2
 460       energia(18)=0.0d0
 461 #endif
 462 #ifdef SPLITELE
 463       energia(3)=ees
 464       energia(16)=evdw1
 465 #else
 466       energia(3)=ees+evdw1
 467       energia(16)=0.0d0
 468 #endif
 469       energia(4)=ecorr
 470       energia(5)=ecorr5
 471       energia(6)=ecorr6
 472       energia(7)=eel_loc
 473       energia(8)=eello_turn3
 474       energia(9)=eello_turn4
 475       energia(10)=eturn6
 476       energia(11)=ebe
 477       energia(12)=escloc
 478       energia(13)=etors
 479       energia(14)=etors_d
 480       energia(15)=ehpb
 481       energia(19)=edihcnstr
 482       energia(17)=estr
 483       energia(20)=Uconst+Uconst_back
 484       energia(21)=esccor
 485       energia(22)=eliptran
 486       energia(23)=Eafmforce
 487       energia(24)=ethetacnstr
 488       energia(25)=Etube
 489       energia(26)=Esaxs_constr
 490       energia(27)=ehomology_constr
 491       energia(28)=edfadis
 492       energia(29)=edfator
 493       energia(30)=edfanei
 494       energia(31)=edfabet
 495 c      write (iout,*) "esaxs_constr",energia(26)
 496 c    Here are the energies showed per procesor if the are more processors
 497 c    per molecule then we sum it up in sum_energy subroutine
 498 c      print *," Processor",myrank," calls SUM_ENERGY"
 499       call sum_energy(energia,.true.)
 500 c      write (iout,*) "After sum_energy: esaxs_constr",energia(26)
 501       if (dyn_ss) call dyn_set_nss
 502 c      print *," Processor",myrank," left SUM_ENERGY"
 503 #ifdef TIMING
 504       time_sumene=time_sumene+MPI_Wtime()-time00
 505 #endif
 506       return
 507       end
 508 c-------------------------------------------------------------------------------
 509       subroutine sum_energy(energia,reduce)
 510       implicit none
 511       include 'DIMENSIONS'
 512 #ifndef ISNAN
 513       external proc_proc
 514 #ifdef WINPGI
 515 cMS$ATTRIBUTES C ::  proc_proc
 516 #endif
 517 #endif
 518 #ifdef MPI
 519       include "mpif.h"
 520       integer ierr
 521       double precision time00
 522 #endif
 523       include 'COMMON.SETUP'
 524       include 'COMMON.IOUNITS'
 525       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 526       include 'COMMON.FFIELD'
 527       include 'COMMON.DERIV'
 528       include 'COMMON.INTERACT'
 529       include 'COMMON.SBRIDGE'
 530       include 'COMMON.CHAIN'
 531       include 'COMMON.VAR'
 532       include 'COMMON.CONTROL'
 533       include 'COMMON.TIME1'
 534       logical reduce
 535       integer i
 536       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
 537      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
 538      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
 539      & eliptran,Eafmforce,Etube,
 540      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
 541       double precision Uconst,etot
 542 #ifdef MPI
 543       if (nfgtasks.gt.1 .and. reduce) then
 544 #ifdef DEBUG
 545         write (iout,*) "energies before REDUCE"
 546         call enerprint(energia)
 547         call flush(iout)
 548 #endif
 549         do i=0,n_ene
 550           enebuff(i)=energia(i)
 551         enddo
 552         time00=MPI_Wtime()
 553         call MPI_Barrier(FG_COMM,IERR)
 554         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 555         time00=MPI_Wtime()
 556         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 557      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 558 #ifdef DEBUG
 559         write (iout,*) "energies after REDUCE"
 560         call enerprint(energia)
 561         call flush(iout)
 562 #endif
 563         time_Reduce=time_Reduce+MPI_Wtime()-time00
 564       endif
 565       if (fg_rank.eq.0) then
 566 #endif
 567       evdw=energia(1)
 568 #ifdef SCP14
 569       evdw2=energia(2)+energia(18)
 570       evdw2_14=energia(18)
 571 #else
 572       evdw2=energia(2)
 573 #endif
 574 #ifdef SPLITELE
 575       ees=energia(3)
 576       evdw1=energia(16)
 577 #else
 578       ees=energia(3)
 579       evdw1=0.0d0
 580 #endif
 581       ecorr=energia(4)
 582       ecorr5=energia(5)
 583       ecorr6=energia(6)
 584       eel_loc=energia(7)
 585       eello_turn3=energia(8)
 586       eello_turn4=energia(9)
 587       eturn6=energia(10)
 588       ebe=energia(11)
 589       escloc=energia(12)
 590       etors=energia(13)
 591       etors_d=energia(14)
 592       ehpb=energia(15)
 593       edihcnstr=energia(19)
 594       estr=energia(17)
 595       Uconst=energia(20)
 596       esccor=energia(21)
 597       eliptran=energia(22)
 598       Eafmforce=energia(23)
 599       ethetacnstr=energia(24)
 600       Etube=energia(25)
 601       esaxs_constr=energia(26)
 602       ehomology_constr=energia(27)
 603       edfadis=energia(28)
 604       edfator=energia(29)
 605       edfanei=energia(30)
 606       edfabet=energia(31)
 607 #ifdef SPLITELE
 608       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 609      & +wang*ebe+wtor*etors+wscloc*escloc
 610      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 611      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 612      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 613      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 614      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 615      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 616      & +wdfa_beta*edfabet
 617 #else
 618       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 619      & +wang*ebe+wtor*etors+wscloc*escloc
 620      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 621      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 622      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 623      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 624      & +Eafmforce
 625      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 626      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 627      & +wdfa_beta*edfabet
 628 #endif
 629       energia(0)=etot
 630 c detecting NaNQ
 631 #ifdef ISNAN
 632 #ifdef AIX
 633       if (isnan(etot).ne.0) energia(0)=1.0d+99
 634 #else
 635       if (isnan(etot)) energia(0)=1.0d+99
 636 #endif
 637 #else
 638       i=0
 639 #ifdef WINPGI
 640       idumm=proc_proc(etot,i)
 641 #else
 642       call proc_proc(etot,i)
 643 #endif
 644       if(i.eq.1)energia(0)=1.0d+99
 645 #endif
 646 #ifdef MPI
 647       endif
 648 #endif
 649       return
 650       end
 651 c-------------------------------------------------------------------------------
 652       subroutine sum_gradient
 653       implicit none
 654       include 'DIMENSIONS'
 655 #ifndef ISNAN
 656       external proc_proc
 657 #ifdef WINPGI
 658 cMS$ATTRIBUTES C ::  proc_proc
 659 #endif
 660 #endif
 661 #ifdef MPI
 662       include 'mpif.h'
 663       integer ierror,ierr
 664       double precision time00,time01
 665 #endif
 666       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 667      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 668      & ,gloc_scbuf(3,-1:maxres)
 669       include 'COMMON.SETUP'
 670       include 'COMMON.IOUNITS'
 671       include 'COMMON.FFIELD'
 672       include 'COMMON.DERIV'
 673       include 'COMMON.INTERACT'
 674       include 'COMMON.SBRIDGE'
 675       include 'COMMON.CHAIN'
 676       include 'COMMON.VAR'
 677       include 'COMMON.CONTROL'
 678       include 'COMMON.TIME1'
 679       include 'COMMON.MAXGRAD'
 680       include 'COMMON.SCCOR'
 681 c      include 'COMMON.MD'
 682       include 'COMMON.QRESTR'
 683       integer i,j,k
 684       double precision scalar
 685       double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
 686      &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
 687      &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
 688      &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
 689      &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
 690      &gsclocx_norm
 691 #ifdef TIMING
 692       time01=MPI_Wtime()
 693 #endif
 694 #ifdef DEBUG
 695       write (iout,*) "sum_gradient gvdwc, gvdwx"
 696       do i=1,nres
 697         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 698      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 699       enddo
 700       call flush(iout)
 701 #endif
 702 #ifdef DEBUG
 703       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 704       do i=0,nres
 705         write (iout,'(i3,3e15.5,5x,3e15.5)')
 706      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 707       enddo
 708       call flush(iout)
 709 #endif
 710 #ifdef MPI
 711 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 712         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 713      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 714 #endif
 715 C
 716 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 717 C            in virtual-bond-vector coordinates
 718 C
 719 #ifdef DEBUG
 720 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 721 c      do i=1,nres-1
 722 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 723 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 724 c      enddo
 725 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 726 c      do i=1,nres-1
 727 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 728 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 729 c      enddo
 730       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 731       do i=1,nres
 732         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 733      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 734      &   g_corr5_loc(i)
 735       enddo
 736       call flush(iout)
 737 #endif
 738 #ifdef DEBUG
 739       write (iout,*) "gsaxsc"
 740       do i=1,nres
 741         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 742       enddo
 743       call flush(iout)
 744 #endif
 745 #ifdef SPLITELE
 746       do i=0,nct
 747         do j=1,3
 748           gradbufc(j,i)=wsc*gvdwc(j,i)+
 749      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 750      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 751      &                wel_loc*gel_loc_long(j,i)+
 752      &                wcorr*gradcorr_long(j,i)+
 753      &                wcorr5*gradcorr5_long(j,i)+
 754      &                wcorr6*gradcorr6_long(j,i)+
 755      &                wturn6*gcorr6_turn_long(j,i)+
 756      &                wstrain*ghpbc(j,i)
 757      &                +wliptran*gliptranc(j,i)
 758      &                +gradafm(j,i)
 759      &                +welec*gshieldc(j,i)
 760      &                +wcorr*gshieldc_ec(j,i)
 761      &                +wturn3*gshieldc_t3(j,i)
 762      &                +wturn4*gshieldc_t4(j,i)
 763      &                +wel_loc*gshieldc_ll(j,i)
 764      &                +wtube*gg_tube(j,i)
 765      &                +wsaxs*gsaxsc(j,i)
 766         enddo
 767       enddo
 768 #else
 769       do i=0,nct
 770         do j=1,3
 771           gradbufc(j,i)=wsc*gvdwc(j,i)+
 772      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 773      &                welec*gelc_long(j,i)+
 774      &                wbond*gradb(j,i)+
 775      &                wel_loc*gel_loc_long(j,i)+
 776      &                wcorr*gradcorr_long(j,i)+
 777      &                wcorr5*gradcorr5_long(j,i)+
 778      &                wcorr6*gradcorr6_long(j,i)+
 779      &                wturn6*gcorr6_turn_long(j,i)+
 780      &                wstrain*ghpbc(j,i)
 781      &                +wliptran*gliptranc(j,i)
 782      &                +gradafm(j,i)
 783      &                 +welec*gshieldc(j,i)
 784      &                 +wcorr*gshieldc_ec(j,i)
 785      &                 +wturn4*gshieldc_t4(j,i)
 786      &                 +wel_loc*gshieldc_ll(j,i)
 787      &                +wtube*gg_tube(j,i)
 788      &                +wsaxs*gsaxsc(j,i)
 789         enddo
 790       enddo
 791 #endif
 792       do i=1,nct
 793         do j=1,3
 794           gradbufc(j,i)=gradbufc(j,i)+
 795      &                wdfa_dist*gdfad(j,i)+
 796      &                wdfa_tor*gdfat(j,i)+
 797      &                wdfa_nei*gdfan(j,i)+
 798      &                wdfa_beta*gdfab(j,i)
 799         enddo
 800       enddo
 801 #ifdef DEBUG
 802       write (iout,*) "gradc from gradbufc"
 803       do i=1,nres
 804         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 805       enddo
 806       call flush(iout)
 807 #endif
 808 #ifdef MPI
 809       if (nfgtasks.gt.1) then
 810       time00=MPI_Wtime()
 811 #ifdef DEBUG
 812       write (iout,*) "gradbufc before allreduce"
 813       do i=1,nres
 814         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 815       enddo
 816       call flush(iout)
 817 #endif
 818       do i=0,nres
 819         do j=1,3
 820           gradbufc_sum(j,i)=gradbufc(j,i)
 821         enddo
 822       enddo
 823 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 824 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 825 c      time_reduce=time_reduce+MPI_Wtime()-time00
 826 #ifdef DEBUG
 827 c      write (iout,*) "gradbufc_sum after allreduce"
 828 c      do i=1,nres
 829 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 830 c      enddo
 831 c      call flush(iout)
 832 #endif
 833 #ifdef TIMING
 834 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 835 #endif
 836 c      do i=nnt,nres
 837       do i=0,nres
 838         do k=1,3
 839           gradbufc(k,i)=0.0d0
 840         enddo
 841       enddo
 842 #ifdef DEBUG
 843       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 844       write (iout,*) (i," jgrad_start",jgrad_start(i),
 845      &                  " jgrad_end  ",jgrad_end(i),
 846      &                  i=igrad_start,igrad_end)
 847 #endif
 848 c
 849 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 850 c do not parallelize this part.
 851 c
 852 c      do i=igrad_start,igrad_end
 853 c        do j=jgrad_start(i),jgrad_end(i)
 854 c          do k=1,3
 855 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 856 c          enddo
 857 c        enddo
 858 c      enddo
 859       do j=1,3
 860         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 861       enddo
 862 c      do i=nres-2,-1,-1
 863       do i=nres-2,0,-1
 864         do j=1,3
 865           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 866         enddo
 867       enddo
 868 #ifdef DEBUG
 869       write (iout,*) "gradbufc after summing"
 870       do i=1,nres
 871         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 872       enddo
 873       call flush(iout)
 874 #endif
 875       else
 876 #endif
 877 #ifdef DEBUG
 878       write (iout,*) "gradbufc"
 879       do i=0,nres
 880         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 881       enddo
 882       call flush(iout)
 883 #endif
 884 c      do i=-1,nres
 885       do i=0,nres
 886         do j=1,3
 887           gradbufc_sum(j,i)=gradbufc(j,i)
 888           gradbufc(j,i)=0.0d0
 889         enddo
 890       enddo
 891       do j=1,3
 892         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 893       enddo
 894 c      do i=nres-2,-1,-1
 895       do i=nres-2,0,-1
 896         do j=1,3
 897           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 898         enddo
 899       enddo
 900 c      do i=nnt,nres-1
 901 c        do k=1,3
 902 c          gradbufc(k,i)=0.0d0
 903 c        enddo
 904 c        do j=i+1,nres
 905 c          do k=1,3
 906 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 907 c          enddo
 908 c        enddo
 909 c      enddo
 910 #ifdef DEBUG
 911       write (iout,*) "gradbufc after summing"
 912       do i=1,nres
 913         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 914       enddo
 915       call flush(iout)
 916 #endif
 917 #ifdef MPI
 918       endif
 919 #endif
 920       do k=1,3
 921         gradbufc(k,nres)=0.0d0
 922       enddo
 923 c      do i=-1,nct
 924       do i=0,nct
 925         do j=1,3
 926 #ifdef SPLITELE
 927 C          print *,gradbufc(1,13)
 928 C          print *,welec*gelc(1,13)
 929 C          print *,wel_loc*gel_loc(1,13)
 930 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 931 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 932 C          print *,wel_loc*gel_loc_long(1,13)
 933 C          print *,gradafm(1,13),"AFM"
 934           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 935      &                wel_loc*gel_loc(j,i)+
 936      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 937      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 938      &                wel_loc*gel_loc_long(j,i)+
 939      &                wcorr*gradcorr_long(j,i)+
 940      &                wcorr5*gradcorr5_long(j,i)+
 941      &                wcorr6*gradcorr6_long(j,i)+
 942      &                wturn6*gcorr6_turn_long(j,i))+
 943      &                wbond*gradb(j,i)+
 944      &                wcorr*gradcorr(j,i)+
 945      &                wturn3*gcorr3_turn(j,i)+
 946      &                wturn4*gcorr4_turn(j,i)+
 947      &                wcorr5*gradcorr5(j,i)+
 948      &                wcorr6*gradcorr6(j,i)+
 949      &                wturn6*gcorr6_turn(j,i)+
 950      &                wsccor*gsccorc(j,i)
 951      &               +wscloc*gscloc(j,i)
 952      &               +wliptran*gliptranc(j,i)
 953      &                +gradafm(j,i)
 954      &                 +welec*gshieldc(j,i)
 955      &                 +welec*gshieldc_loc(j,i)
 956      &                 +wcorr*gshieldc_ec(j,i)
 957      &                 +wcorr*gshieldc_loc_ec(j,i)
 958      &                 +wturn3*gshieldc_t3(j,i)
 959      &                 +wturn3*gshieldc_loc_t3(j,i)
 960      &                 +wturn4*gshieldc_t4(j,i)
 961      &                 +wturn4*gshieldc_loc_t4(j,i)
 962      &                 +wel_loc*gshieldc_ll(j,i)
 963      &                 +wel_loc*gshieldc_loc_ll(j,i)
 964      &                +wtube*gg_tube(j,i)
 965
 966 #else
 967           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 968      &                wel_loc*gel_loc(j,i)+
 969      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 970      &                welec*gelc_long(j,i)+
 971      &                wel_loc*gel_loc_long(j,i)+
 972      &                wcorr*gcorr_long(j,i)+
 973      &                wcorr5*gradcorr5_long(j,i)+
 974      &                wcorr6*gradcorr6_long(j,i)+
 975      &                wturn6*gcorr6_turn_long(j,i))+
 976      &                wbond*gradb(j,i)+
 977      &                wcorr*gradcorr(j,i)+
 978      &                wturn3*gcorr3_turn(j,i)+
 979      &                wturn4*gcorr4_turn(j,i)+
 980      &                wcorr5*gradcorr5(j,i)+
 981      &                wcorr6*gradcorr6(j,i)+
 982      &                wturn6*gcorr6_turn(j,i)+
 983      &                wsccor*gsccorc(j,i)
 984      &               +wscloc*gscloc(j,i)
 985      &               +wliptran*gliptranc(j,i)
 986      &                +gradafm(j,i)
 987      &                 +welec*gshieldc(j,i)
 988      &                 +welec*gshieldc_loc(j,i)
 989      &                 +wcorr*gshieldc_ec(j,i)
 990      &                 +wcorr*gshieldc_loc_ec(j,i)
 991      &                 +wturn3*gshieldc_t3(j,i)
 992      &                 +wturn3*gshieldc_loc_t3(j,i)
 993      &                 +wturn4*gshieldc_t4(j,i)
 994      &                 +wturn4*gshieldc_loc_t4(j,i)
 995      &                 +wel_loc*gshieldc_ll(j,i)
 996      &                 +wel_loc*gshieldc_loc_ll(j,i)
 997      &                +wtube*gg_tube(j,i)
 998
 999
1000 #endif
1001           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
1002      &                  wbond*gradbx(j,i)+
1003      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
1004      &                  wsccor*gsccorx(j,i)
1005      &                 +wscloc*gsclocx(j,i)
1006      &                 +wliptran*gliptranx(j,i)
1007      &                 +welec*gshieldx(j,i)
1008      &                 +wcorr*gshieldx_ec(j,i)
1009      &                 +wturn3*gshieldx_t3(j,i)
1010      &                 +wturn4*gshieldx_t4(j,i)
1011      &                 +wel_loc*gshieldx_ll(j,i)
1012      &                 +wtube*gg_tube_sc(j,i)
1013      &                 +wsaxs*gsaxsx(j,i)
1014
1015
1016
1017         enddo
1018       enddo
1019       if (constr_homology.gt.0) then
1020         do i=1,nct
1021           do j=1,3
1022             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
1023             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
1024           enddo
1025         enddo
1026       endif
1027 #ifdef DEBUG
1028       write (iout,*) "gradc gradx gloc after adding"
1029       write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1030      &   i,(gradc(j,0,icg),j=1,3),(gradx(j,0,icg),j=1,3)
1031       do i=1,nres
1032         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1033      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1034       enddo
1035 #endif
1036 #ifdef DEBUG
1037       write (iout,*) "gloc before adding corr"
1038       do i=1,4*nres
1039         write (iout,*) i,gloc(i,icg)
1040       enddo
1041 #endif
1042       do i=1,nres-3
1043         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
1044      &   +wcorr5*g_corr5_loc(i)
1045      &   +wcorr6*g_corr6_loc(i)
1046      &   +wturn4*gel_loc_turn4(i)
1047      &   +wturn3*gel_loc_turn3(i)
1048      &   +wturn6*gel_loc_turn6(i)
1049      &   +wel_loc*gel_loc_loc(i)
1050       enddo
1051 #ifdef DEBUG
1052       write (iout,*) "gloc after adding corr"
1053       do i=1,4*nres
1054         write (iout,*) i,gloc(i,icg)
1055       enddo
1056 #endif
1057 #ifdef MPI
1058       if (nfgtasks.gt.1) then
1059         do j=1,3
1060           do i=0,nres
1061             gradbufc(j,i)=gradc(j,i,icg)
1062             gradbufx(j,i)=gradx(j,i,icg)
1063           enddo
1064         enddo
1065         do i=1,4*nres
1066           glocbuf(i)=gloc(i,icg)
1067         enddo
1068 c#define DEBUG
1069 #ifdef DEBUG
1070       write (iout,*) "gloc_sc before reduce"
1071       do i=1,nres
1072        do j=1,1
1073         write (iout,*) i,j,gloc_sc(j,i,icg)
1074        enddo
1075       enddo
1076 #endif
1077 c#undef DEBUG
1078         do i=1,nres
1079          do j=1,3
1080           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1081          enddo
1082         enddo
1083         time00=MPI_Wtime()
1084         call MPI_Barrier(FG_COMM,IERR)
1085         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1086         time00=MPI_Wtime()
1087         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*(nres+1),
1088      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1089         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*(nres+1),
1090      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1091         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1092      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1093         time_reduce=time_reduce+MPI_Wtime()-time00
1094         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1095      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1096         time_reduce=time_reduce+MPI_Wtime()-time00
1097 #ifdef DEBUG
1098       write (iout,*) "gradc after reduce"
1099       do i=0,nres
1100        do j=1,3
1101         write (iout,*) i,j,gradc(j,i,icg)
1102        enddo
1103       enddo
1104 #endif
1105 #ifdef DEBUG
1106       write (iout,*) "gloc_sc after reduce"
1107       do i=1,nres
1108        do j=1,1
1109         write (iout,*) i,j,gloc_sc(j,i,icg)
1110        enddo
1111       enddo
1112 #endif
1113 #ifdef DEBUG
1114       write (iout,*) "gloc after reduce"
1115       do i=1,4*nres
1116         write (iout,*) i,gloc(i,icg)
1117       enddo
1118 #endif
1119       endif
1120 #endif
1121       if (gnorm_check) then
1122 c
1123 c Compute the maximum elements of the gradient
1124 c
1125       gvdwc_max=0.0d0
1126       gvdwc_scp_max=0.0d0
1127       gelc_max=0.0d0
1128       gvdwpp_max=0.0d0
1129       gradb_max=0.0d0
1130       ghpbc_max=0.0d0
1131       gradcorr_max=0.0d0
1132       gel_loc_max=0.0d0
1133       gcorr3_turn_max=0.0d0
1134       gcorr4_turn_max=0.0d0
1135       gradcorr5_max=0.0d0
1136       gradcorr6_max=0.0d0
1137       gcorr6_turn_max=0.0d0
1138       gsccorrc_max=0.0d0
1139       gscloc_max=0.0d0
1140       gvdwx_max=0.0d0
1141       gradx_scp_max=0.0d0
1142       ghpbx_max=0.0d0
1143       gradxorr_max=0.0d0
1144       gsccorrx_max=0.0d0
1145       gsclocx_max=0.0d0
1146       do i=1,nct
1147         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1148         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1149         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1150         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1151      &   gvdwc_scp_max=gvdwc_scp_norm
1152         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1153         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1154         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1155         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1156         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1157         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1158         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1159         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1160         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1161         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1162         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1163         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1164         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1165      &    gcorr3_turn(1,i)))
1166         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1167      &    gcorr3_turn_max=gcorr3_turn_norm
1168         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1169      &    gcorr4_turn(1,i)))
1170         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1171      &    gcorr4_turn_max=gcorr4_turn_norm
1172         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1173         if (gradcorr5_norm.gt.gradcorr5_max)
1174      &    gradcorr5_max=gradcorr5_norm
1175         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1176         if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1177         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1178      &    gcorr6_turn(1,i)))
1179         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1180      &    gcorr6_turn_max=gcorr6_turn_norm
1181         gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1182         if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1183         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1184         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1185         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1186         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1187         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1188         if (gradx_scp_norm.gt.gradx_scp_max)
1189      &    gradx_scp_max=gradx_scp_norm
1190         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1191         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1192         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1193         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1194         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1195         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1196         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1197         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1198       enddo
1199       if (gradout) then
1200 #if (defined AIX || defined CRAY)
1201         open(istat,file=statname,position="append")
1202 #else
1203         open(istat,file=statname,access="append")
1204 #endif
1205         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1206      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1207      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1208      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1209      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1210      &     gsccorrx_max,gsclocx_max
1211         close(istat)
1212         if (gvdwc_max.gt.1.0d4) then
1213           write (iout,*) "gvdwc gvdwx gradb gradbx"
1214           do i=nnt,nct
1215             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1216      &        gradb(j,i),gradbx(j,i),j=1,3)
1217           enddo
1218           call pdbout(0.0d0,'cipiszcze',iout)
1219           call flush(iout)
1220         endif
1221       endif
1222       endif
1223 #ifdef DEBUG
1224       write (iout,*) "gradc gradx gloc"
1225       do i=1,nres
1226         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1227      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1228       enddo
1229 #endif
1230 #ifdef TIMING
1231       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1232 #endif
1233       return
1234       end
1235 c-------------------------------------------------------------------------------
1236       subroutine rescale_weights(t_bath)
1237       implicit none
1238 #ifdef MPI
1239       include 'mpif.h'
1240       integer ierror
1241 #endif
1242       include 'DIMENSIONS'
1243       include 'COMMON.IOUNITS'
1244       include 'COMMON.FFIELD'
1245       include 'COMMON.SBRIDGE'
1246       include 'COMMON.CONTROL'
1247       double precision t_bath
1248       double precision facT,facT2,facT3,facT4,facT5
1249       double precision kfac /2.4d0/
1250       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1251 c      facT=temp0/t_bath
1252 c      facT=2*temp0/(t_bath+temp0)
1253       if (rescale_mode.eq.0) then
1254         facT=1.0d0
1255         facT2=1.0d0
1256         facT3=1.0d0
1257         facT4=1.0d0
1258         facT5=1.0d0
1259       else if (rescale_mode.eq.1) then
1260         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1261         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1262         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1263         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1264         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1265       else if (rescale_mode.eq.2) then
1266         x=t_bath/temp0
1267         x2=x*x
1268         x3=x2*x
1269         x4=x3*x
1270         x5=x4*x
1271         facT=licznik/dlog(dexp(x)+dexp(-x))
1272         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1273         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1274         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1275         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1276       else
1277         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1278         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1279 #ifdef MPI
1280        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1281 #endif
1282        stop 555
1283       endif
1284       if (shield_mode.gt.0) then
1285        wscp=weights(2)*fact
1286        wsc=weights(1)*fact
1287        wvdwpp=weights(16)*fact
1288       endif
1289       welec=weights(3)*fact
1290       wcorr=weights(4)*fact3
1291       wcorr5=weights(5)*fact4
1292       wcorr6=weights(6)*fact5
1293       wel_loc=weights(7)*fact2
1294       wturn3=weights(8)*fact2
1295       wturn4=weights(9)*fact3
1296       wturn6=weights(10)*fact5
1297       wtor=weights(13)*fact
1298       wtor_d=weights(14)*fact2
1299       wsccor=weights(21)*fact
1300       if (scale_umb) wumb=t_bath/temp0
1301 c      write (iout,*) "scale_umb",scale_umb
1302 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1303
1304       return
1305       end
1306 C------------------------------------------------------------------------
1307       subroutine enerprint(energia)
1308       implicit none
1309       include 'DIMENSIONS'
1310       include 'COMMON.IOUNITS'
1311       include 'COMMON.FFIELD'
1312       include 'COMMON.SBRIDGE'
1313       include 'COMMON.QRESTR'
1314       double precision energia(0:n_ene)
1315       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1316      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1317      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1318      & eello_turn6,
1319      & eliptran,Eafmforce,Etube,
1320      & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1321       etot=energia(0)
1322       evdw=energia(1)
1323       evdw2=energia(2)
1324 #ifdef SCP14
1325       evdw2=energia(2)+energia(18)
1326 #else
1327       evdw2=energia(2)
1328 #endif
1329       ees=energia(3)
1330 #ifdef SPLITELE
1331       evdw1=energia(16)
1332 #endif
1333       ecorr=energia(4)
1334       ecorr5=energia(5)
1335       ecorr6=energia(6)
1336       eel_loc=energia(7)
1337       eello_turn3=energia(8)
1338       eello_turn4=energia(9)
1339       eello_turn6=energia(10)
1340       ebe=energia(11)
1341       escloc=energia(12)
1342       etors=energia(13)
1343       etors_d=energia(14)
1344       ehpb=energia(15)
1345       edihcnstr=energia(19)
1346       estr=energia(17)
1347       Uconst=energia(20)
1348       esccor=energia(21)
1349       eliptran=energia(22)
1350       Eafmforce=energia(23)
1351       ethetacnstr=energia(24)
1352       etube=energia(25)
1353       esaxs=energia(26)
1354       ehomology_constr=energia(27)
1355 C     Bartek
1356       edfadis = energia(28)
1357       edfator = energia(29)
1358       edfanei = energia(30)
1359       edfabet = energia(31)
1360 #ifdef SPLITELE
1361       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1362      &  estr,wbond,ebe,wang,
1363      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1364 #ifdef FOURBODY
1365      &  ecorr,wcorr,
1366      &  ecorr5,wcorr5,ecorr6,wcorr6,
1367 #endif
1368      &  eel_loc,wel_loc,eello_turn3,wturn3,
1369      &  eello_turn4,wturn4,
1370 #ifdef FOURBODY
1371      &  eello_turn6,wturn6,
1372 #endif
1373      &  esccor,wsccor,edihcnstr,
1374      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1375      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1376      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1377      &  edfabet,wdfa_beta,
1378      &  etot
1379    10 format (/'Virtual-chain energies:'//
1380      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1381      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1382      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1383      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1384      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1385      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1386      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1387      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1388      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1389      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1390      & ' (SS bridges & dist. cnstr.)'/
1391 #ifdef FOURBODY
1392      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1393      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1394      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1395 #endif
1396      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1397      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1398      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1399 #ifdef FOURBODY
1400      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1401 #endif
1402      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1403      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1404      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1405      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1406      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1407      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1408      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1409      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1410      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1411      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1412      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1413      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1414      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1415      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1416      & 'ETOT=  ',1pE16.6,' (total)')
1417
1418 #else
1419       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1420      &  estr,wbond,ebe,wang,
1421      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1422 #ifdef FOURBODY
1423      &  ecorr,wcorr,
1424      &  ecorr5,wcorr5,ecorr6,wcorr6,
1425 #endif
1426      &  eel_loc,wel_loc,eello_turn3,wturn3,
1427      &  eello_turn4,wturn4,
1428 #ifdef FOURBODY
1429      &  eello_turn6,wturn6,
1430 #endif
1431      &  esccor,wsccor,edihcnstr,
1432      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1433      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1434      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1435      &  edfabet,wdfa_beta,
1436      &  etot
1437    10 format (/'Virtual-chain energies:'//
1438      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1439      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1440      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1441      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1442      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1443      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1444      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1445      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1446      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1447      & ' (SS bridges & dist. restr.)'/
1448 #ifdef FOURBODY
1449      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1450      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1451      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1452 #endif
1453      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1454      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1455      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1456 #ifdef FOURBODY
1457      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1458 #endif
1459      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1460      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1461      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1462      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1463      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1464      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1465      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1466      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1467      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1468      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1469      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1470      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1471      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1472      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1473      & 'ETOT=  ',1pE16.6,' (total)')
1474 #endif
1475       return
1476       end
1477 C-----------------------------------------------------------------------
1478       subroutine elj(evdw)
1479 C
1480 C This subroutine calculates the interaction energy of nonbonded side chains
1481 C assuming the LJ potential of interaction.
1482 C
1483       implicit none
1484       double precision accur
1485       include 'DIMENSIONS'
1486       parameter (accur=1.0d-10)
1487       include 'COMMON.GEO'
1488       include 'COMMON.VAR'
1489       include 'COMMON.LOCAL'
1490       include 'COMMON.CHAIN'
1491       include 'COMMON.DERIV'
1492       include 'COMMON.INTERACT'
1493       include 'COMMON.TORSION'
1494       include 'COMMON.SBRIDGE'
1495       include 'COMMON.NAMES'
1496       include 'COMMON.IOUNITS'
1497       include 'COMMON.SPLITELE'
1498 #ifdef FOURBODY
1499       include 'COMMON.CONTACTS'
1500       include 'COMMON.CONTMAT'
1501 #endif
1502       double precision gg(3)
1503       double precision evdw,evdwij
1504       integer i,j,k,itypi,itypj,itypi1,num_conti,iint,ikont
1505       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1506      & sigij,r0ij,rcut,sqrij,sss1,sssgrad1
1507       double precision fcont,fprimcont
1508       double precision fracinbuf,sslipi,sslipj,ssgradlipj,ssgradlipi,
1509      & faclip
1510       double precision sscale,sscagrad,sscagradlip,sscalelip
1511       double precision gg_lipi(3),gg_lipj(3)
1512       double precision boxshift
1513 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1514       evdw=0.0D0
1515       gg_lipi=0.0d0
1516       gg_lipj=0.0d0
1517 c      do i=iatsc_s,iatsc_e
1518       do ikont=g_listscsc_start,g_listscsc_end
1519         i=newcontlisti(ikont)
1520         j=newcontlistj(ikont)
1521         itypi=iabs(itype(i))
1522         if (itypi.eq.ntyp1) cycle
1523         itypi1=iabs(itype(i+1))
1524         xi=c(1,nres+i)
1525         yi=c(2,nres+i)
1526         zi=c(3,nres+i)
1527         call to_box(xi,yi,zi)
1528         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1529 C Change 12/1/95
1530         num_conti=0
1531 C
1532 C Calculate SC interaction energy.
1533 C
1534 c        do iint=1,nint_gr(i)
1535 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1536 cd   &                  'iend=',iend(i,iint)
1537 c          do j=istart(i,iint),iend(i,iint)
1538             itypj=iabs(itype(j))
1539             if (itypj.eq.ntyp1) cycle
1540             xj=c(1,nres+j)
1541             yj=c(2,nres+j)
1542             zj=c(3,nres+j)
1543             call to_box(xj,yj,zj)
1544             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1545             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1546      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1547             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1548      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1549             xj=boxshift(xj-xi,boxxsize)
1550             yj=boxshift(yj-yi,boxysize)
1551             zj=boxshift(zj-zi,boxzsize)
1552 C Change 12/1/95 to calculate four-body interactions
1553             rij=xj*xj+yj*yj+zj*zj
1554             rrij=1.0D0/rij
1555             sqrij=dsqrt(rij)
1556             sss1=sscale(sqrij,r_cut_int)
1557             if (sss1.eq.0.0d0) cycle
1558             sssgrad1=sscagrad(sqrij,r_cut_int)
1559
1560 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1561             eps0ij=eps(itypi,itypj)
1562             fac=rrij**expon2
1563             faclip=fac
1564 C have you changed here?
1565             e1=fac*fac*aa
1566             e2=fac*bb
1567             evdwij=e1+e2
1568 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1569 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1570 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1571 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1572 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1573 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1574             evdw=evdw+sss1*evdwij
1575 C
1576 C Calculate the components of the gradient in DC and X
1577 C
1578             fac=-rrij*(e1+evdwij)*sss1
1579      &          +evdwij*sssgrad1/sqrij/expon
1580             gg(1)=xj*fac
1581             gg(2)=yj*fac
1582             gg(3)=zj*fac
1583             gg_lipi(3)=(sss1/2.0d0*(faclip*faclip*
1584      &         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1585      &        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj))))/expon
1586             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1587             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1588             do k=1,3
1589               gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
1590               gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
1591               gvdwc(k,i)=gvdwc(k,i)-gg(k)+gg_lipi(k)
1592               gvdwc(k,j)=gvdwc(k,j)+gg(k)+gg_lipj(k)
1593             enddo
1594 cgrad            do k=i,j-1
1595 cgrad              do l=1,3
1596 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1597 cgrad              enddo
1598 cgrad            enddo
1599 C
1600 #ifdef FOURBODY
1601 C 12/1/95, revised on 5/20/97
1602 C
1603 C Calculate the contact function. The ith column of the array JCONT will
1604 C contain the numbers of atoms that make contacts with the atom I (of numbers
1605 C greater than I). The arrays FACONT and GACONT will contain the values of
1606 C the contact function and its derivative.
1607 C
1608 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1609 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1610 C Uncomment next line, if the correlation interactions are contact function only
1611             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1612               rij=dsqrt(rij)
1613               sigij=sigma(itypi,itypj)
1614               r0ij=rs0(itypi,itypj)
1615 C
1616 C Check whether the SC's are not too far to make a contact.
1617 C
1618               rcut=1.5d0*r0ij
1619               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1620 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1621 C
1622               if (fcont.gt.0.0D0) then
1623 C If the SC-SC distance if close to sigma, apply spline.
1624 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1625 cAdam &             fcont1,fprimcont1)
1626 cAdam           fcont1=1.0d0-fcont1
1627 cAdam           if (fcont1.gt.0.0d0) then
1628 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1629 cAdam             fcont=fcont*fcont1
1630 cAdam           endif
1631 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1632 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1633 cga             do k=1,3
1634 cga               gg(k)=gg(k)*eps0ij
1635 cga             enddo
1636 cga             eps0ij=-evdwij*eps0ij
1637 C Uncomment for AL's type of SC correlation interactions.
1638 cadam           eps0ij=-evdwij
1639                 num_conti=num_conti+1
1640                 jcont(num_conti,i)=j
1641                 facont(num_conti,i)=fcont*eps0ij
1642                 fprimcont=eps0ij*fprimcont/rij
1643                 fcont=expon*fcont
1644 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1645 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1646 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1647 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1648                 gacont(1,num_conti,i)=-fprimcont*xj
1649                 gacont(2,num_conti,i)=-fprimcont*yj
1650                 gacont(3,num_conti,i)=-fprimcont*zj
1651 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1652 cd              write (iout,'(2i3,3f10.5)')
1653 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1654               endif
1655             endif
1656 #endif
1657 c          enddo      ! j
1658 c        enddo        ! iint
1659 C Change 12/1/95
1660 #ifdef FOURBODY
1661         num_cont(i)=num_conti
1662 #endif
1663       enddo          ! i
1664       do i=1,nct
1665         do j=1,3
1666           gvdwc(j,i)=expon*gvdwc(j,i)
1667           gvdwx(j,i)=expon*gvdwx(j,i)
1668         enddo
1669       enddo
1670 C******************************************************************************
1671 C
1672 C                              N O T E !!!
1673 C
1674 C To save time, the factor of EXPON has been extracted from ALL components
1675 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1676 C use!
1677 C
1678 C******************************************************************************
1679       return
1680       end
1681 C-----------------------------------------------------------------------------
1682       subroutine eljk(evdw)
1683 C
1684 C This subroutine calculates the interaction energy of nonbonded side chains
1685 C assuming the LJK potential of interaction.
1686 C
1687       implicit none
1688       include 'DIMENSIONS'
1689       include 'COMMON.GEO'
1690       include 'COMMON.VAR'
1691       include 'COMMON.LOCAL'
1692       include 'COMMON.CHAIN'
1693       include 'COMMON.DERIV'
1694       include 'COMMON.INTERACT'
1695       include 'COMMON.IOUNITS'
1696       include 'COMMON.NAMES'
1697       include 'COMMON.SPLITELE'
1698       double precision gg(3)
1699       double precision evdw,evdwij
1700       integer i,j,k,itypi,itypj,itypi1,iint,ikont
1701       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1702      & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1
1703       logical scheck
1704       double precision boxshift
1705       double precision fracinbuf,sslipi,sslipj,ssgradlipj,ssgradlipi,
1706      & faclip
1707       double precision gg_lipi(3),gg_lipj(3)
1708       double precision sscale,sscagrad,sscagradlip,sscalelip
1709 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1710       evdw=0.0D0
1711       gg_lipi=0.0d0
1712       gg_lipj=0.0d0
1713 c      do i=iatsc_s,iatsc_e
1714       do ikont=g_listscsc_start,g_listscsc_end
1715         i=newcontlisti(ikont)
1716         j=newcontlistj(ikont)
1717         itypi=iabs(itype(i))
1718         if (itypi.eq.ntyp1) cycle
1719         itypi1=iabs(itype(i+1))
1720         xi=c(1,nres+i)
1721         yi=c(2,nres+i)
1722         zi=c(3,nres+i)
1723         call to_box(xi,yi,zi)
1724         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1725 C
1726 C Calculate SC interaction energy.
1727 C
1728 c        do iint=1,nint_gr(i)
1729 c          do j=istart(i,iint),iend(i,iint)
1730             itypj=iabs(itype(j))
1731             if (itypj.eq.ntyp1) cycle
1732             xj=c(1,nres+j)
1733             yj=c(2,nres+j)
1734             zj=c(3,nres+j)
1735             call to_box(xj,yj,zj)
1736             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1737             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1738      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1739             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1740      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1741             xj=boxshift(xj-xi,boxxsize)
1742             yj=boxshift(yj-yi,boxysize)
1743             zj=boxshift(zj-zi,boxzsize)
1744             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1745             fac_augm=rrij**expon
1746             e_augm=augm(itypi,itypj)*fac_augm
1747             r_inv_ij=dsqrt(rrij)
1748             rij=1.0D0/r_inv_ij
1749             sss1=sscale(rij,r_cut_int)
1750             if (sss1.eq.0.0d0) cycle
1751             sssgrad1=sscagrad(rij,r_cut_int)
1752             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1753             fac=r_shift_inv**expon
1754             faclip=fac
1755 C have you changed here?
1756             e1=fac*fac*aa
1757             e2=fac*bb
1758             evdwij=e_augm+e1+e2
1759 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1760 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1761 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1762 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1763 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1764 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1765 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1766             evdw=evdw+evdwij*sss1
1767 C
1768 C Calculate the components of the gradient in DC and X
1769 C
1770             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1771      &          +evdwij*sssgrad1*r_inv_ij/expon
1772             gg(1)=xj*fac
1773             gg(2)=yj*fac
1774             gg(3)=zj*fac
1775             gg_lipi(3)=(sss1/2.0d0*(faclip*faclip*
1776      &         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1777      &        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj))))/expon
1778             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1779             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1780             do k=1,3
1781               gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
1782               gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
1783               gvdwc(k,i)=gvdwc(k,i)-gg(k)+gg_lipi(k)
1784               gvdwc(k,j)=gvdwc(k,j)+gg(k)+gg_lipj(k)
1785             enddo
1786 cgrad            do k=i,j-1
1787 cgrad              do l=1,3
1788 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1789 cgrad              enddo
1790 cgrad            enddo
1791 c          enddo      ! j
1792 c        enddo        ! iint
1793       enddo          ! i
1794       do i=1,nct
1795         do j=1,3
1796           gvdwc(j,i)=expon*gvdwc(j,i)
1797           gvdwx(j,i)=expon*gvdwx(j,i)
1798         enddo
1799       enddo
1800       return
1801       end
1802 C-----------------------------------------------------------------------------
1803       subroutine ebp(evdw)
1804 C
1805 C This subroutine calculates the interaction energy of nonbonded side chains
1806 C assuming the Berne-Pechukas potential of interaction.
1807 C
1808       implicit none
1809       include 'DIMENSIONS'
1810       include 'COMMON.GEO'
1811       include 'COMMON.VAR'
1812       include 'COMMON.LOCAL'
1813       include 'COMMON.CHAIN'
1814       include 'COMMON.DERIV'
1815       include 'COMMON.NAMES'
1816       include 'COMMON.INTERACT'
1817       include 'COMMON.IOUNITS'
1818       include 'COMMON.CALC'
1819       include 'COMMON.SPLITELE'
1820       integer icall
1821       common /srutu/ icall
1822       double precision evdw
1823       integer itypi,itypj,itypi1,iint,ind,ikont
1824       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi,
1825      & sss1,sssgrad1
1826       double precision fracinbuf,sslipi,sslipj,ssgradlipj,ssgradlipi,
1827      & faclip
1828       double precision sscale,sscagrad,sscagradlip,sscalelip
1829       double precision boxshift
1830 c     double precision rrsave(maxdim)
1831       logical lprn
1832       evdw=0.0D0
1833 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1834       gg_lipi=0.0d0
1835       gg_lipj=0.0d0
1836 c     if (icall.eq.0) then
1837 c       lprn=.true.
1838 c     else
1839         lprn=.false.
1840 c     endif
1841       ind=0
1842 c      do i=iatsc_s,iatsc_e
1843       do ikont=g_listscsc_start,g_listscsc_end
1844         i=newcontlisti(ikont)
1845         j=newcontlistj(ikont)
1846         itypi=iabs(itype(i))
1847         if (itypi.eq.ntyp1) cycle
1848         itypi1=iabs(itype(i+1))
1849         xi=c(1,nres+i)
1850         yi=c(2,nres+i)
1851         zi=c(3,nres+i)
1852         call to_box(xi,yi,zi)
1853         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1854         dxi=dc_norm(1,nres+i)
1855         dyi=dc_norm(2,nres+i)
1856         dzi=dc_norm(3,nres+i)
1857 c        dsci_inv=dsc_inv(itypi)
1858         dsci_inv=vbld_inv(i+nres)
1859 C
1860 C Calculate SC interaction energy.
1861 C
1862 c        do iint=1,nint_gr(i)
1863 c          do j=istart(i,iint),iend(i,iint)
1864             ind=ind+1
1865             itypj=iabs(itype(j))
1866             if (itypj.eq.ntyp1) cycle
1867 c            dscj_inv=dsc_inv(itypj)
1868             dscj_inv=vbld_inv(j+nres)
1869             chi1=chi(itypi,itypj)
1870             chi2=chi(itypj,itypi)
1871             chi12=chi1*chi2
1872             chip1=chip(itypi)
1873             chip2=chip(itypj)
1874             chip12=chip1*chip2
1875             alf1=alp(itypi)
1876             alf2=alp(itypj)
1877             alf12=0.5D0*(alf1+alf2)
1878 C For diagnostics only!!!
1879 c           chi1=0.0D0
1880 c           chi2=0.0D0
1881 c           chi12=0.0D0
1882 c           chip1=0.0D0
1883 c           chip2=0.0D0
1884 c           chip12=0.0D0
1885 c           alf1=0.0D0
1886 c           alf2=0.0D0
1887 c           alf12=0.0D0
1888             xj=c(1,nres+j)
1889             yj=c(2,nres+j)
1890             zj=c(3,nres+j)
1891             call to_box(xj,yj,zj)
1892             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1893             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1894      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1895             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1896      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1897             xj=boxshift(xj-xi,boxxsize)
1898             yj=boxshift(yj-yi,boxysize)
1899             zj=boxshift(zj-zi,boxzsize)
1900             dxj=dc_norm(1,nres+j)
1901             dyj=dc_norm(2,nres+j)
1902             dzj=dc_norm(3,nres+j)
1903             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1904 cd          if (icall.eq.0) then
1905 cd            rrsave(ind)=rrij
1906 cd          else
1907 cd            rrij=rrsave(ind)
1908 cd          endif
1909             rij=dsqrt(rrij)
1910             sss1=sscale(1.0d0/rij,r_cut_int)
1911             if (sss1.eq.0.0d0) cycle
1912             sssgrad1=sscagrad(1.0d0/rij,r_cut_int)
1913 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1914             call sc_angular
1915 C Calculate whole angle-dependent part of epsilon and contributions
1916 C to its derivatives
1917 C have you changed here?
1918             fac=(rrij*sigsq)**expon2
1919             faclip=fac
1920             e1=fac*fac*aa
1921             e2=fac*bb
1922             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1923             eps2der=evdwij*eps3rt
1924             eps3der=evdwij*eps2rt
1925             evdwij=evdwij*eps2rt*eps3rt
1926             evdw=evdw+sss1*evdwij
1927             if (lprn) then
1928             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1929             epsi=bb**2/aa
1930 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1931 cd     &        restyp(itypi),i,restyp(itypj),j,
1932 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1933 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1934 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1935 cd     &        evdwij
1936             endif
1937 C Calculate gradient components.
1938             e1=e1*eps1*eps2rt**2*eps3rt**2
1939             fac=-expon*(e1+evdwij)
1940             sigder=fac/sigsq
1941             fac=rrij*fac
1942      &          +evdwij*sssgrad1/sss1*rij
1943 C Calculate radial part of the gradient
1944             gg(1)=xj*fac
1945             gg(2)=yj*fac
1946             gg(3)=zj*fac
1947             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1948      &        *(eps3rt*eps3rt)*sss1/2.0d0*(faclip*faclip*
1949      &         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1950      &        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1951             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1952             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1953 C Calculate the angular part of the gradient and sum add the contributions
1954 C to the appropriate components of the Cartesian gradient.
1955             call sc_grad
1956 !          enddo      ! j
1957 !        enddo        ! iint
1958       enddo          ! i
1959 c     stop
1960       return
1961       end
1962 C-----------------------------------------------------------------------------
1963       subroutine egb(evdw)
1964 C
1965 C This subroutine calculates the interaction energy of nonbonded side chains
1966 C assuming the Gay-Berne potential of interaction.
1967 C
1968       implicit none
1969       include 'DIMENSIONS'
1970       include 'COMMON.GEO'
1971       include 'COMMON.VAR'
1972       include 'COMMON.LOCAL'
1973       include 'COMMON.CHAIN'
1974       include 'COMMON.DERIV'
1975       include 'COMMON.NAMES'
1976       include 'COMMON.INTERACT'
1977       include 'COMMON.IOUNITS'
1978       include 'COMMON.CALC'
1979       include 'COMMON.CONTROL'
1980       include 'COMMON.SPLITELE'
1981       include 'COMMON.SBRIDGE'
1982       logical lprn
1983       double precision evdw
1984       integer itypi,itypj,itypi1,iint,ind,ikont
1985       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1986       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1987      & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip
1988       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1989       double precision boxshift
1990       evdw=0.0D0
1991 ccccc      energy_dec=.false.
1992 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1993       gg_lipi=0.0d0
1994       gg_lipj=0.0d0
1995       lprn=.false.
1996 c     if (icall.eq.0) lprn=.false.
1997       ind=0
1998 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1999 C we have the original box)
2000 C      do xshift=-1,1
2001 C      do yshift=-1,1
2002 C      do zshift=-1,1
2003 c      do i=iatsc_s,iatsc_e
2004       do ikont=g_listscsc_start,g_listscsc_end
2005         i=newcontlisti(ikont)
2006         j=newcontlistj(ikont)
2007         itypi=iabs(itype(i))
2008         if (itypi.eq.ntyp1) cycle
2009         itypi1=iabs(itype(i+1))
2010         xi=c(1,nres+i)
2011         yi=c(2,nres+i)
2012         zi=c(3,nres+i)
2013         call to_box(xi,yi,zi)
2014 C define scaling factor for lipids
2015
2016 C        if (positi.le.0) positi=positi+boxzsize
2017 C        print *,i
2018 C first for peptide groups
2019 c for each residue check if it is in lipid or lipid water border area
2020         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2021 C          xi=xi+xshift*boxxsize
2022 C          yi=yi+yshift*boxysize
2023 C          zi=zi+zshift*boxzsize
2024
2025         dxi=dc_norm(1,nres+i)
2026         dyi=dc_norm(2,nres+i)
2027         dzi=dc_norm(3,nres+i)
2028 c        dsci_inv=dsc_inv(itypi)
2029         dsci_inv=vbld_inv(i+nres)
2030 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
2031 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
2032 C
2033 C Calculate SC interaction energy.
2034 C
2035 c        do iint=1,nint_gr(i)
2036 c          do j=istart(i,iint),iend(i,iint)
2037             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
2038
2039 c              write(iout,*) "PRZED ZWYKLE", evdwij
2040               call dyn_ssbond_ene(i,j,evdwij)
2041 c              write(iout,*) "PO ZWYKLE", evdwij
2042
2043               evdw=evdw+evdwij
2044               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2045      &                        'evdw',i,j,evdwij,' ss'
2046 C triple bond artifac removal
2047               do k=j+1,iend(i,iint)
2048 C search over all next residues
2049                 if (dyn_ss_mask(k)) then
2050 C check if they are cysteins
2051 C              write(iout,*) 'k=',k
2052
2053 c              write(iout,*) "PRZED TRI", evdwij
2054                   evdwij_przed_tri=evdwij
2055                   call triple_ssbond_ene(i,j,k,evdwij)
2056 c               if(evdwij_przed_tri.ne.evdwij) then
2057 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
2058 c               endif
2059
2060 c              write(iout,*) "PO TRI", evdwij
2061 C call the energy function that removes the artifical triple disulfide
2062 C bond the soubroutine is located in ssMD.F
2063                   evdw=evdw+evdwij
2064                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2065      &                        'evdw',i,j,evdwij,'tss'
2066                 endif!dyn_ss_mask(k)
2067               enddo! k
2068             ELSE
2069               ind=ind+1
2070               itypj=iabs(itype(j))
2071               if (itypj.eq.ntyp1) cycle
2072 c            dscj_inv=dsc_inv(itypj)
2073               dscj_inv=vbld_inv(j+nres)
2074 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
2075 c     &       1.0d0/vbld(j+nres)
2076 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
2077               sig0ij=sigma(itypi,itypj)
2078               chi1=chi(itypi,itypj)
2079               chi2=chi(itypj,itypi)
2080               chi12=chi1*chi2
2081               chip1=chip(itypi)
2082               chip2=chip(itypj)
2083               chip12=chip1*chip2
2084               alf1=alp(itypi)
2085               alf2=alp(itypj)
2086               alf12=0.5D0*(alf1+alf2)
2087 C For diagnostics only!!!
2088 c           chi1=0.0D0
2089 c           chi2=0.0D0
2090 c           chi12=0.0D0
2091 c           chip1=0.0D0
2092 c           chip2=0.0D0
2093 c           chip12=0.0D0
2094 c           alf1=0.0D0
2095 c           alf2=0.0D0
2096 c           alf12=0.0D0
2097               xj=c(1,nres+j)
2098               yj=c(2,nres+j)
2099               zj=c(3,nres+j)
2100               call to_box(xj,yj,zj)
2101               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2102               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2103      &          +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2104               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2105      &          +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2106 c            write (iout,*) "aa bb",aa_lip(itypi,itypj),
2107 c     &       bb_lip(itypi,itypj),aa_aq(itypi,itypj),
2108 c     &       bb_aq(itypi,itypj),aa,bb
2109 c            write (iout,*) (sslipi+sslipj)/2.0d0,
2110 c     &        (2.0d0-sslipi-sslipj)/2.0d0
2111
2112 c      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2113 c      if (aa.ne.aa_aq(itypi,itypj)) write(iout,'(2e15.5)')
2114 c     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2115 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2116 C      print *,sslipi,sslipj,bordlipbot,zi,zj
2117               xj=boxshift(xj-xi,boxxsize)
2118               yj=boxshift(yj-yi,boxysize)
2119               zj=boxshift(zj-zi,boxzsize)
2120               dxj=dc_norm(1,nres+j)
2121               dyj=dc_norm(2,nres+j)
2122               dzj=dc_norm(3,nres+j)
2123 C            xj=xj-xi
2124 C            yj=yj-yi
2125 C            zj=zj-zi
2126 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2127 c            write (iout,*) "j",j," dc_norm",
2128 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2129               rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2130               rij=dsqrt(rrij)
2131               sss=sscale(1.0d0/rij,r_cut_int)
2132 c            write (iout,'(a7,4f8.3)')
2133 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2134               if (sss.eq.0.0d0) cycle
2135               sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2136 C Calculate angle-dependent terms of energy and contributions to their
2137 C derivatives.
2138               call sc_angular
2139               sigsq=1.0D0/sigsq
2140               sig=sig0ij*dsqrt(sigsq)
2141               rij_shift=1.0D0/rij-sig+sig0ij
2142 c              if (energy_dec)
2143 c     &        write (iout,*) "rij",1.0d0/rij," rij_shift",rij_shift,
2144 c     &       " sig",sig," sig0ij",sig0ij
2145 c for diagnostics; uncomment
2146 c            rij_shift=1.2*sig0ij
2147 C I hate to put IF's in the loops, but here don't have another choice!!!!
2148               if (rij_shift.le.0.0D0) then
2149                 evdw=1.0D20
2150 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2151 cd     &        restyp(itypi),i,restyp(itypj),j,
2152 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2153 c                return
2154               endif
2155               sigder=-sig*sigsq
2156 c---------------------------------------------------------------
2157               rij_shift=1.0D0/rij_shift
2158               fac=rij_shift**expon
2159 C here to start with
2160 C            if (c(i,3).gt.
2161               faclip=fac
2162               e1=fac*fac*aa
2163               e2=fac*bb
2164               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2165               eps2der=evdwij*eps3rt
2166               eps3der=evdwij*eps2rt
2167 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2168 C     &((sslipi+sslipj)/2.0d0+
2169 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2170 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2171 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2172               evdwij=evdwij*eps2rt*eps3rt
2173               evdw=evdw+evdwij*sss
2174               if (lprn) then
2175                 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2176                 epsi=bb**2/aa
2177                 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2178      &           restyp(itypi),i,restyp(itypj),j,
2179      &           epsi,sigm,chi1,chi2,chip1,chip2,
2180      &           eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2181      &           om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2182      &           evdwij
2183               endif
2184
2185               if (energy_dec) write (iout,'(a,2i5,4f10.5,e15.5)')
2186      &          'r sss evdw',i,j,1.0d0/rij,sss,sslipi,sslipj,evdwij
2187
2188 C Calculate gradient components.
2189               e1=e1*eps1*eps2rt**2*eps3rt**2
2190               fac=-expon*(e1+evdwij)*rij_shift
2191               sigder=fac*sigder
2192               fac=rij*fac
2193 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2194 c     &      evdwij,fac,sigma(itypi,itypj),expon
2195               fac=fac+evdwij*sssgrad/sss*rij
2196 c            fac=0.0d0
2197 C Calculate the radial part of the gradient
2198               gg_lipi(3)=eps1*(eps2rt*eps2rt)
2199      &          *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2200      &           (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2201      &          +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2202               gg_lipj(3)=ssgradlipj*gg_lipi(3)
2203               gg_lipi(3)=gg_lipi(3)*ssgradlipi
2204 C            gg_lipi(3)=0.0d0
2205 C            gg_lipj(3)=0.0d0
2206               gg(1)=xj*fac
2207               gg(2)=yj*fac
2208               gg(3)=zj*fac
2209 C Calculate angular part of the gradient.
2210 c            call sc_grad_scale(sss)
2211               call sc_grad
2212             ENDIF    ! dyn_ss
2213 c          enddo      ! j
2214 c        enddo        ! iint
2215       enddo          ! i
2216 C      enddo          ! zshift
2217 C      enddo          ! yshift
2218 C      enddo          ! xshift
2219 c      write (iout,*) "Number of loop steps in EGB:",ind
2220 cccc      energy_dec=.false.
2221       return
2222       end
2223 C-----------------------------------------------------------------------------
2224       subroutine egbv(evdw)
2225 C
2226 C This subroutine calculates the interaction energy of nonbonded side chains
2227 C assuming the Gay-Berne-Vorobjev potential of interaction.
2228 C
2229       implicit none
2230       include 'DIMENSIONS'
2231       include 'COMMON.GEO'
2232       include 'COMMON.VAR'
2233       include 'COMMON.LOCAL'
2234       include 'COMMON.CHAIN'
2235       include 'COMMON.DERIV'
2236       include 'COMMON.NAMES'
2237       include 'COMMON.INTERACT'
2238       include 'COMMON.IOUNITS'
2239       include 'COMMON.CALC'
2240       include 'COMMON.SPLITELE'
2241       double precision boxshift
2242       integer icall
2243       common /srutu/ icall
2244       logical lprn
2245       double precision evdw
2246       integer itypi,itypj,itypi1,iint,ind,ikont
2247       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2248      & xi,yi,zi,fac_augm,e_augm
2249       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2250      & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip,sssgrad1
2251       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2252       evdw=0.0D0
2253 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2254       gg_lipi=0.0d0
2255       gg_lipj=0.0d0
2256       lprn=.false.
2257 c     if (icall.eq.0) lprn=.true.
2258       ind=0
2259 c      do i=iatsc_s,iatsc_e
2260       do ikont=g_listscsc_start,g_listscsc_end
2261         i=newcontlisti(ikont)
2262         j=newcontlistj(ikont)
2263         itypi=iabs(itype(i))
2264         if (itypi.eq.ntyp1) cycle
2265         itypi1=iabs(itype(i+1))
2266         xi=c(1,nres+i)
2267         yi=c(2,nres+i)
2268         zi=c(3,nres+i)
2269         call to_box(xi,yi,zi)
2270 C define scaling factor for lipids
2271
2272 C        if (positi.le.0) positi=positi+boxzsize
2273 C        print *,i
2274 C first for peptide groups
2275 c for each residue check if it is in lipid or lipid water border area
2276         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2277         dxi=dc_norm(1,nres+i)
2278         dyi=dc_norm(2,nres+i)
2279         dzi=dc_norm(3,nres+i)
2280 c        dsci_inv=dsc_inv(itypi)
2281         dsci_inv=vbld_inv(i+nres)
2282 C
2283 C Calculate SC interaction energy.
2284 C
2285 c        do iint=1,nint_gr(i)
2286 c          do j=istart(i,iint),iend(i,iint)
2287             ind=ind+1
2288             itypj=iabs(itype(j))
2289             if (itypj.eq.ntyp1) cycle
2290 c            dscj_inv=dsc_inv(itypj)
2291             dscj_inv=vbld_inv(j+nres)
2292             sig0ij=sigma(itypi,itypj)
2293             r0ij=r0(itypi,itypj)
2294             chi1=chi(itypi,itypj)
2295             chi2=chi(itypj,itypi)
2296             chi12=chi1*chi2
2297             chip1=chip(itypi)
2298             chip2=chip(itypj)
2299             chip12=chip1*chip2
2300             alf1=alp(itypi)
2301             alf2=alp(itypj)
2302             alf12=0.5D0*(alf1+alf2)
2303 C For diagnostics only!!!
2304 c           chi1=0.0D0
2305 c           chi2=0.0D0
2306 c           chi12=0.0D0
2307 c           chip1=0.0D0
2308 c           chip2=0.0D0
2309 c           chip12=0.0D0
2310 c           alf1=0.0D0
2311 c           alf2=0.0D0
2312 c           alf12=0.0D0
2313            xj=c(1,nres+j)
2314            yj=c(2,nres+j)
2315            zj=c(3,nres+j)
2316            call to_box(xj,yj,zj)
2317            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2318            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2319      &       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2320            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2321      &       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2322 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2323 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2324 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2325            xj=boxshift(xj-xi,boxxsize)
2326            yj=boxshift(yj-yi,boxysize)
2327            zj=boxshift(zj-zi,boxzsize)
2328            dxj=dc_norm(1,nres+j)
2329            dyj=dc_norm(2,nres+j)
2330            dzj=dc_norm(3,nres+j)
2331            rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2332            rij=dsqrt(rrij)
2333            sss=sscale(1.0d0/rij,r_cut_int)
2334            if (sss.eq.0.0d0) cycle
2335            sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2336 C Calculate angle-dependent terms of energy and contributions to their
2337 C derivatives.
2338            call sc_angular
2339            sigsq=1.0D0/sigsq
2340            sig=sig0ij*dsqrt(sigsq)
2341            rij_shift=1.0D0/rij-sig+r0ij
2342 C I hate to put IF's in the loops, but here don't have another choice!!!!
2343            if (rij_shift.le.0.0D0) then
2344              evdw=1.0D20
2345              return
2346            endif
2347            sigder=-sig*sigsq
2348 c---------------------------------------------------------------
2349            rij_shift=1.0D0/rij_shift
2350            fac=rij_shift**expon
2351            faclip=fac
2352            e1=fac*fac*aa
2353            e2=fac*bb
2354            evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2355            eps2der=evdwij*eps3rt
2356            eps3der=evdwij*eps2rt
2357            fac_augm=rrij**expon
2358            e_augm=augm(itypi,itypj)*fac_augm
2359            evdwij=evdwij*eps2rt*eps3rt
2360            evdw=evdw+evdwij+e_augm
2361            if (lprn) then
2362              sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2363              epsi=bb**2/aa
2364              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2365      &        restyp(itypi),i,restyp(itypj),j,
2366      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2367      &        chi1,chi2,chip1,chip2,
2368      &        eps1,eps2rt**2,eps3rt**2,
2369      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2370      &        evdwij+e_augm
2371            endif
2372 C Calculate gradient components.
2373            e1=e1*eps1*eps2rt**2*eps3rt**2
2374            fac=-expon*(e1+evdwij)*rij_shift
2375            sigder=fac*sigder
2376            fac=rij*fac-2*expon*rrij*e_augm
2377            fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2378 C Calculate the radial part of the gradient
2379            gg_lipi(3)=eps1*(eps2rt*eps2rt)
2380      &       *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2381      &       (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2382      &       +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2383            gg_lipj(3)=ssgradlipj*gg_lipi(3)
2384            gg_lipi(3)=gg_lipi(3)*ssgradlipi
2385            gg(1)=xj*fac
2386            gg(2)=yj*fac
2387            gg(3)=zj*fac
2388 C Calculate angular part of the gradient.
2389 c            call sc_grad_scale(sss)
2390            call sc_grad
2391 c          enddo      ! j
2392 c        enddo        ! iint
2393       enddo          ! i
2394       end
2395 C-----------------------------------------------------------------------------
2396       subroutine sc_angular
2397 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2398 C om12. Called by ebp, egb, and egbv.
2399       implicit none
2400       include 'COMMON.CALC'
2401       include 'COMMON.IOUNITS'
2402       erij(1)=xj*rij
2403       erij(2)=yj*rij
2404       erij(3)=zj*rij
2405       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2406       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2407       om12=dxi*dxj+dyi*dyj+dzi*dzj
2408       chiom12=chi12*om12
2409 C Calculate eps1(om12) and its derivative in om12
2410       faceps1=1.0D0-om12*chiom12
2411       faceps1_inv=1.0D0/faceps1
2412       eps1=dsqrt(faceps1_inv)
2413 C Following variable is eps1*deps1/dom12
2414       eps1_om12=faceps1_inv*chiom12
2415 c diagnostics only
2416 c      faceps1_inv=om12
2417 c      eps1=om12
2418 c      eps1_om12=1.0d0
2419 c      write (iout,*) "om12",om12," eps1",eps1
2420 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2421 C and om12.
2422       om1om2=om1*om2
2423       chiom1=chi1*om1
2424       chiom2=chi2*om2
2425       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2426       sigsq=1.0D0-facsig*faceps1_inv
2427       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2428       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2429       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2430 c diagnostics only
2431 c      sigsq=1.0d0
2432 c      sigsq_om1=0.0d0
2433 c      sigsq_om2=0.0d0
2434 c      sigsq_om12=0.0d0
2435 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2436 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2437 c     &    " eps1",eps1
2438 C Calculate eps2 and its derivatives in om1, om2, and om12.
2439       chipom1=chip1*om1
2440       chipom2=chip2*om2
2441       chipom12=chip12*om12
2442       facp=1.0D0-om12*chipom12
2443       facp_inv=1.0D0/facp
2444       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2445 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2446 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2447 C Following variable is the square root of eps2
2448       eps2rt=1.0D0-facp1*facp_inv
2449 C Following three variables are the derivatives of the square root of eps
2450 C in om1, om2, and om12.
2451       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2452       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2453       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2454 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2455       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2456 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2457 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2458 c     &  " eps2rt_om12",eps2rt_om12
2459 C Calculate whole angle-dependent part of epsilon and contributions
2460 C to its derivatives
2461       return
2462       end
2463 C----------------------------------------------------------------------------
2464       subroutine sc_grad
2465       implicit real*8 (a-h,o-z)
2466       include 'DIMENSIONS'
2467       include 'COMMON.CHAIN'
2468       include 'COMMON.DERIV'
2469       include 'COMMON.CALC'
2470       include 'COMMON.IOUNITS'
2471       double precision dcosom1(3),dcosom2(3)
2472 cc      print *,'sss=',sss
2473       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2474       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2475       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2476      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2477 c diagnostics only
2478 c      eom1=0.0d0
2479 c      eom2=0.0d0
2480 c      eom12=evdwij*eps1_om12
2481 c end diagnostics
2482 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2483 c     &  " sigder",sigder
2484 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2485 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2486       do k=1,3
2487         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2488         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2489       enddo
2490       do k=1,3
2491         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2492       enddo
2493 c      write (iout,*) "gg",(gg(k),k=1,3)
2494       do k=1,3
2495         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2496      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2497      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2498         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2499      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2500      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2501 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2502 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2503 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2504 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2505       enddo
2506 C
2507 C Calculate the components of the gradient in DC and X
2508 C
2509 cgrad      do k=i,j-1
2510 cgrad        do l=1,3
2511 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2512 cgrad        enddo
2513 cgrad      enddo
2514       do l=1,3
2515         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2516         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2517       enddo
2518       return
2519       end
2520 C-----------------------------------------------------------------------
2521       subroutine e_softsphere(evdw)
2522 C
2523 C This subroutine calculates the interaction energy of nonbonded side chains
2524 C assuming the LJ potential of interaction.
2525 C
2526       implicit real*8 (a-h,o-z)
2527       include 'DIMENSIONS'
2528       parameter (accur=1.0d-10)
2529       include 'COMMON.GEO'
2530       include 'COMMON.VAR'
2531       include 'COMMON.LOCAL'
2532       include 'COMMON.CHAIN'
2533       include 'COMMON.DERIV'
2534       include 'COMMON.INTERACT'
2535       include 'COMMON.TORSION'
2536       include 'COMMON.SBRIDGE'
2537       include 'COMMON.NAMES'
2538       include 'COMMON.IOUNITS'
2539 c      include 'COMMON.CONTACTS'
2540       dimension gg(3)
2541       double precision boxshift
2542 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2543       evdw=0.0D0
2544 c      do i=iatsc_s,iatsc_e
2545       do ikont=g_listscsc_start,g_listscsc_end
2546         i=newcontlisti(ikont)
2547         j=newcontlistj(ikont)
2548         itypi=iabs(itype(i))
2549         if (itypi.eq.ntyp1) cycle
2550         itypi1=iabs(itype(i+1))
2551         xi=c(1,nres+i)
2552         yi=c(2,nres+i)
2553         zi=c(3,nres+i)
2554         call to_box(xi,yi,zi)
2555 C
2556 C Calculate SC interaction energy.
2557 C
2558 c        do iint=1,nint_gr(i)
2559 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2560 cd   &                  'iend=',iend(i,iint)
2561 c          do j=istart(i,iint),iend(i,iint)
2562             itypj=iabs(itype(j))
2563             if (itypj.eq.ntyp1) cycle
2564             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2565             yj=boxshift(c(2,nres+j)-yi,boxysize)
2566             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2567             rij=xj*xj+yj*yj+zj*zj
2568 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2569             r0ij=r0(itypi,itypj)
2570             r0ijsq=r0ij*r0ij
2571 c            print *,i,j,r0ij,dsqrt(rij)
2572             if (rij.lt.r0ijsq) then
2573               evdwij=0.25d0*(rij-r0ijsq)**2
2574               fac=rij-r0ijsq
2575             else
2576               evdwij=0.0d0
2577               fac=0.0d0
2578             endif
2579             evdw=evdw+evdwij
2580 C
2581 C Calculate the components of the gradient in DC and X
2582 C
2583             gg(1)=xj*fac
2584             gg(2)=yj*fac
2585             gg(3)=zj*fac
2586             do k=1,3
2587               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2588               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2589               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2590               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2591             enddo
2592 cgrad            do k=i,j-1
2593 cgrad              do l=1,3
2594 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2595 cgrad              enddo
2596 cgrad            enddo
2597 c          enddo ! j
2598 c        enddo ! iint
2599       enddo ! i
2600       return
2601       end
2602 C--------------------------------------------------------------------------
2603       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2604      &              eello_turn4)
2605 C
2606 C Soft-sphere potential of p-p interaction
2607 C
2608       implicit real*8 (a-h,o-z)
2609       include 'DIMENSIONS'
2610       include 'COMMON.CONTROL'
2611       include 'COMMON.IOUNITS'
2612       include 'COMMON.GEO'
2613       include 'COMMON.VAR'
2614       include 'COMMON.LOCAL'
2615       include 'COMMON.CHAIN'
2616       include 'COMMON.DERIV'
2617       include 'COMMON.INTERACT'
2618 c      include 'COMMON.CONTACTS'
2619       include 'COMMON.TORSION'
2620       include 'COMMON.VECTORS'
2621       include 'COMMON.FFIELD'
2622       dimension ggg(3)
2623       double precision boxshift
2624 C      write(iout,*) 'In EELEC_soft_sphere'
2625       ees=0.0D0
2626       evdw1=0.0D0
2627       eel_loc=0.0d0
2628       eello_turn3=0.0d0
2629       eello_turn4=0.0d0
2630       ind=0
2631       do i=iatel_s,iatel_e
2632         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2633         dxi=dc(1,i)
2634         dyi=dc(2,i)
2635         dzi=dc(3,i)
2636         xmedi=c(1,i)+0.5d0*dxi
2637         ymedi=c(2,i)+0.5d0*dyi
2638         zmedi=c(3,i)+0.5d0*dzi
2639         call to_box(xmedi,ymedi,zmedi)
2640         num_conti=0
2641 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2642         do j=ielstart(i),ielend(i)
2643           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2644           ind=ind+1
2645           iteli=itel(i)
2646           itelj=itel(j)
2647           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2648           r0ij=rpp(iteli,itelj)
2649           r0ijsq=r0ij*r0ij
2650           dxj=dc(1,j)
2651           dyj=dc(2,j)
2652           dzj=dc(3,j)
2653           xj=c(1,j)+0.5D0*dxj
2654           yj=c(2,j)+0.5D0*dyj
2655           zj=c(3,j)+0.5D0*dzj
2656           call to_box(xj,yj,zj)
2657           xj=boxshift(xj-xmedi,boxxsize)
2658           yj=boxshift(yj-ymedi,boxysize)
2659           zj=boxshift(zj-zmedi,boxzsize)
2660           rij=xj*xj+yj*yj+zj*zj
2661             sss=sscale(sqrt(rij),r_cut_int)
2662             sssgrad=sscagrad(sqrt(rij),r_cut_int)
2663           if (rij.lt.r0ijsq) then
2664             evdw1ij=0.25d0*(rij-r0ijsq)**2
2665             fac=rij-r0ijsq
2666           else
2667             evdw1ij=0.0d0
2668             fac=0.0d0
2669           endif
2670           evdw1=evdw1+evdw1ij*sss
2671 C
2672 C Calculate contributions to the Cartesian gradient.
2673 C
2674           ggg(1)=fac*xj*sssgrad
2675           ggg(2)=fac*yj*sssgrad
2676           ggg(3)=fac*zj*sssgrad
2677           do k=1,3
2678             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2679             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2680           enddo
2681 *
2682 * Loop over residues i+1 thru j-1.
2683 *
2684 cgrad          do k=i+1,j-1
2685 cgrad            do l=1,3
2686 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2687 cgrad            enddo
2688 cgrad          enddo
2689         enddo ! j
2690       enddo   ! i
2691 cgrad      do i=nnt,nct-1
2692 cgrad        do k=1,3
2693 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2694 cgrad        enddo
2695 cgrad        do j=i+1,nct-1
2696 cgrad          do k=1,3
2697 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2698 cgrad          enddo
2699 cgrad        enddo
2700 cgrad      enddo
2701       return
2702       end
2703 c------------------------------------------------------------------------------
2704       subroutine vec_and_deriv
2705       implicit real*8 (a-h,o-z)
2706       include 'DIMENSIONS'
2707 #ifdef MPI
2708       include 'mpif.h'
2709 #endif
2710       include 'COMMON.IOUNITS'
2711       include 'COMMON.GEO'
2712       include 'COMMON.VAR'
2713       include 'COMMON.LOCAL'
2714       include 'COMMON.CHAIN'
2715       include 'COMMON.VECTORS'
2716       include 'COMMON.SETUP'
2717       include 'COMMON.TIME1'
2718       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2719 C Compute the local reference systems. For reference system (i), the
2720 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2721 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2722 #ifdef PARVEC
2723       do i=ivec_start,ivec_end
2724 #else
2725       do i=1,nres-1
2726 #endif
2727           if (i.eq.nres-1) then
2728 C Case of the last full residue
2729 C Compute the Z-axis
2730             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2731             costh=dcos(pi-theta(nres))
2732             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2733             do k=1,3
2734               uz(k,i)=fac*uz(k,i)
2735             enddo
2736 C Compute the derivatives of uz
2737             uzder(1,1,1)= 0.0d0
2738             uzder(2,1,1)=-dc_norm(3,i-1)
2739             uzder(3,1,1)= dc_norm(2,i-1)
2740             uzder(1,2,1)= dc_norm(3,i-1)
2741             uzder(2,2,1)= 0.0d0
2742             uzder(3,2,1)=-dc_norm(1,i-1)
2743             uzder(1,3,1)=-dc_norm(2,i-1)
2744             uzder(2,3,1)= dc_norm(1,i-1)
2745             uzder(3,3,1)= 0.0d0
2746             uzder(1,1,2)= 0.0d0
2747             uzder(2,1,2)= dc_norm(3,i)
2748             uzder(3,1,2)=-dc_norm(2,i)
2749             uzder(1,2,2)=-dc_norm(3,i)
2750             uzder(2,2,2)= 0.0d0
2751             uzder(3,2,2)= dc_norm(1,i)
2752             uzder(1,3,2)= dc_norm(2,i)
2753             uzder(2,3,2)=-dc_norm(1,i)
2754             uzder(3,3,2)= 0.0d0
2755 C Compute the Y-axis
2756             facy=fac
2757             do k=1,3
2758               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2759             enddo
2760 C Compute the derivatives of uy
2761             do j=1,3
2762               do k=1,3
2763                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2764      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2765                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2766               enddo
2767               uyder(j,j,1)=uyder(j,j,1)-costh
2768               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2769             enddo
2770             do j=1,2
2771               do k=1,3
2772                 do l=1,3
2773                   uygrad(l,k,j,i)=uyder(l,k,j)
2774                   uzgrad(l,k,j,i)=uzder(l,k,j)
2775                 enddo
2776               enddo
2777             enddo
2778             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2779             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2780             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2781             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2782           else
2783 C Other residues
2784 C Compute the Z-axis
2785             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2786             costh=dcos(pi-theta(i+2))
2787             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2788             do k=1,3
2789               uz(k,i)=fac*uz(k,i)
2790             enddo
2791 C Compute the derivatives of uz
2792             uzder(1,1,1)= 0.0d0
2793             uzder(2,1,1)=-dc_norm(3,i+1)
2794             uzder(3,1,1)= dc_norm(2,i+1)
2795             uzder(1,2,1)= dc_norm(3,i+1)
2796             uzder(2,2,1)= 0.0d0
2797             uzder(3,2,1)=-dc_norm(1,i+1)
2798             uzder(1,3,1)=-dc_norm(2,i+1)
2799             uzder(2,3,1)= dc_norm(1,i+1)
2800             uzder(3,3,1)= 0.0d0
2801             uzder(1,1,2)= 0.0d0
2802             uzder(2,1,2)= dc_norm(3,i)
2803             uzder(3,1,2)=-dc_norm(2,i)
2804             uzder(1,2,2)=-dc_norm(3,i)
2805             uzder(2,2,2)= 0.0d0
2806             uzder(3,2,2)= dc_norm(1,i)
2807             uzder(1,3,2)= dc_norm(2,i)
2808             uzder(2,3,2)=-dc_norm(1,i)
2809             uzder(3,3,2)= 0.0d0
2810 C Compute the Y-axis
2811             facy=fac
2812             do k=1,3
2813               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2814             enddo
2815 C Compute the derivatives of uy
2816             do j=1,3
2817               do k=1,3
2818                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2819      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2820                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2821               enddo
2822               uyder(j,j,1)=uyder(j,j,1)-costh
2823               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2824             enddo
2825             do j=1,2
2826               do k=1,3
2827                 do l=1,3
2828                   uygrad(l,k,j,i)=uyder(l,k,j)
2829                   uzgrad(l,k,j,i)=uzder(l,k,j)
2830                 enddo
2831               enddo
2832             enddo
2833             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2834             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2835             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2836             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2837           endif
2838       enddo
2839       do i=1,nres-1
2840         vbld_inv_temp(1)=vbld_inv(i+1)
2841         if (i.lt.nres-1) then
2842           vbld_inv_temp(2)=vbld_inv(i+2)
2843           else
2844           vbld_inv_temp(2)=vbld_inv(i)
2845           endif
2846         do j=1,2
2847           do k=1,3
2848             do l=1,3
2849               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2850               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2851             enddo
2852           enddo
2853         enddo
2854       enddo
2855 #if defined(PARVEC) && defined(MPI)
2856       if (nfgtasks1.gt.1) then
2857         time00=MPI_Wtime()
2858 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2859 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2860 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2861         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2862      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2863      &   FG_COMM1,IERR)
2864         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2865      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2866      &   FG_COMM1,IERR)
2867         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2868      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2869      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2870         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2871      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2872      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2873         time_gather=time_gather+MPI_Wtime()-time00
2874       endif
2875 #endif
2876 #ifdef DEBUG
2877       if (fg_rank.eq.0) then
2878         write (iout,*) "Arrays UY and UZ"
2879         do i=1,nres-1
2880           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2881      &     (uz(k,i),k=1,3)
2882         enddo
2883       endif
2884 #endif
2885       return
2886       end
2887 C--------------------------------------------------------------------------
2888       subroutine set_matrices
2889       implicit real*8 (a-h,o-z)
2890       include 'DIMENSIONS'
2891 #ifdef MPI
2892       include "mpif.h"
2893       include "COMMON.SETUP"
2894       integer IERR
2895       integer status(MPI_STATUS_SIZE)
2896 #endif
2897       include 'COMMON.IOUNITS'
2898       include 'COMMON.GEO'
2899       include 'COMMON.VAR'
2900       include 'COMMON.LOCAL'
2901       include 'COMMON.CHAIN'
2902       include 'COMMON.DERIV'
2903       include 'COMMON.INTERACT'
2904       include 'COMMON.CORRMAT'
2905       include 'COMMON.TORSION'
2906       include 'COMMON.VECTORS'
2907       include 'COMMON.FFIELD'
2908       double precision auxvec(2),auxmat(2,2)
2909 C
2910 C Compute the virtual-bond-torsional-angle dependent quantities needed
2911 C to calculate the el-loc multibody terms of various order.
2912 C
2913 c      write(iout,*) 'nphi=',nphi,nres
2914 c      write(iout,*) "itype2loc",itype2loc
2915 #ifdef PARMAT
2916       do i=ivec_start+2,ivec_end+2
2917 #else
2918       do i=3,nres+1
2919 #endif
2920         ii=ireschain(i-2)
2921 c        write (iout,*) "i",i,i-2," ii",ii
2922         if (ii.eq.0) cycle
2923         innt=chain_border(1,ii)
2924         inct=chain_border(2,ii)
2925 c        write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
2926 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
2927         if (i.gt. innt+2 .and. i.lt.inct+2) then
2928           iti = itype2loc(itype(i-2))
2929         else
2930           iti=nloctyp
2931         endif
2932 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2933         if (i.gt. innt+1 .and. i.lt.inct+1) then
2934           iti1 = itype2loc(itype(i-1))
2935         else
2936           iti1=nloctyp
2937         endif
2938 c        write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
2939 c     &  " iti1",itype(i-1),iti1
2940 #ifdef NEWCORR
2941         cost1=dcos(theta(i-1))
2942         sint1=dsin(theta(i-1))
2943         sint1sq=sint1*sint1
2944         sint1cub=sint1sq*sint1
2945         sint1cost1=2*sint1*cost1
2946 c        write (iout,*) "bnew1",i,iti
2947 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2948 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2949 c        write (iout,*) "bnew2",i,iti
2950 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2951 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2952         do k=1,2
2953           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2954           b1(k,i-2)=sint1*b1k
2955           gtb1(k,i-2)=cost1*b1k-sint1sq*
2956      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2957           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2958           b2(k,i-2)=sint1*b2k
2959           gtb2(k,i-2)=cost1*b2k-sint1sq*
2960      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2961         enddo
2962         do k=1,2
2963           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2964           cc(1,k,i-2)=sint1sq*aux
2965           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
2966      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2967           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2968           dd(1,k,i-2)=sint1sq*aux
2969           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
2970      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2971         enddo
2972         cc(2,1,i-2)=cc(1,2,i-2)
2973         cc(2,2,i-2)=-cc(1,1,i-2)
2974         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2975         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2976         dd(2,1,i-2)=dd(1,2,i-2)
2977         dd(2,2,i-2)=-dd(1,1,i-2)
2978         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2979         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2980         do k=1,2
2981           do l=1,2
2982             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2983             EE(l,k,i-2)=sint1sq*aux
2984             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2985           enddo
2986         enddo
2987         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2988         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2989         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2990         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2991         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2992         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2993         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2994 c        b1tilde(1,i-2)=b1(1,i-2)
2995 c        b1tilde(2,i-2)=-b1(2,i-2)
2996 c        b2tilde(1,i-2)=b2(1,i-2)
2997 c        b2tilde(2,i-2)=-b2(2,i-2)
2998 #ifdef DEBUG
2999         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3000         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3001         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3002         write (iout,*) 'theta=', theta(i-1)
3003 #endif
3004 #else
3005         if (i.gt. innt+2 .and. i.lt.inct+2) then
3006 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3007           iti = itype2loc(itype(i-2))
3008         else
3009           iti=nloctyp
3010         endif
3011 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3012 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3013         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3014           iti1 = itype2loc(itype(i-1))
3015         else
3016           iti1=nloctyp
3017         endif
3018         b1(1,i-2)=b(3,iti)
3019         b1(2,i-2)=b(5,iti)
3020         b2(1,i-2)=b(2,iti)
3021         b2(2,i-2)=b(4,iti)
3022         do k=1,2
3023           do l=1,2
3024            CC(k,l,i-2)=ccold(k,l,iti)
3025            DD(k,l,i-2)=ddold(k,l,iti)
3026            EE(k,l,i-2)=eeold(k,l,iti)
3027            gtEE(k,l,i-2)=0.0d0
3028           enddo
3029         enddo
3030 #endif
3031         b1tilde(1,i-2)= b1(1,i-2)
3032         b1tilde(2,i-2)=-b1(2,i-2)
3033         b2tilde(1,i-2)= b2(1,i-2)
3034         b2tilde(2,i-2)=-b2(2,i-2)
3035 c
3036         Ctilde(1,1,i-2)= CC(1,1,i-2)
3037         Ctilde(1,2,i-2)= CC(1,2,i-2)
3038         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3039         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3040 c
3041         Dtilde(1,1,i-2)= DD(1,1,i-2)
3042         Dtilde(1,2,i-2)= DD(1,2,i-2)
3043         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3044         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3045 #ifdef DEBUG
3046         write(iout,*) "i",i," iti",iti
3047         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3048         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3049 #endif
3050       enddo
3051       mu=0.0d0
3052 #ifdef PARMAT
3053       do i=ivec_start+2,ivec_end+2
3054 #else
3055       do i=3,nres+1
3056 #endif
3057 c        if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3058         if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3059           sin1=dsin(phi(i))
3060           cos1=dcos(phi(i))
3061           sintab(i-2)=sin1
3062           costab(i-2)=cos1
3063           obrot(1,i-2)=cos1
3064           obrot(2,i-2)=sin1
3065           sin2=dsin(2*phi(i))
3066           cos2=dcos(2*phi(i))
3067           sintab2(i-2)=sin2
3068           costab2(i-2)=cos2
3069           obrot2(1,i-2)=cos2
3070           obrot2(2,i-2)=sin2
3071           Ug(1,1,i-2)=-cos1
3072           Ug(1,2,i-2)=-sin1
3073           Ug(2,1,i-2)=-sin1
3074           Ug(2,2,i-2)= cos1
3075           Ug2(1,1,i-2)=-cos2
3076           Ug2(1,2,i-2)=-sin2
3077           Ug2(2,1,i-2)=-sin2
3078           Ug2(2,2,i-2)= cos2
3079         else
3080           costab(i-2)=1.0d0
3081           sintab(i-2)=0.0d0
3082           obrot(1,i-2)=1.0d0
3083           obrot(2,i-2)=0.0d0
3084           obrot2(1,i-2)=0.0d0
3085           obrot2(2,i-2)=0.0d0
3086           Ug(1,1,i-2)=1.0d0
3087           Ug(1,2,i-2)=0.0d0
3088           Ug(2,1,i-2)=0.0d0
3089           Ug(2,2,i-2)=1.0d0
3090           Ug2(1,1,i-2)=0.0d0
3091           Ug2(1,2,i-2)=0.0d0
3092           Ug2(2,1,i-2)=0.0d0
3093           Ug2(2,2,i-2)=0.0d0
3094         endif
3095         if (i .gt. 3) then
3096           obrot_der(1,i-2)=-sin1
3097           obrot_der(2,i-2)= cos1
3098           Ugder(1,1,i-2)= sin1
3099           Ugder(1,2,i-2)=-cos1
3100           Ugder(2,1,i-2)=-cos1
3101           Ugder(2,2,i-2)=-sin1
3102           dwacos2=cos2+cos2
3103           dwasin2=sin2+sin2
3104           obrot2_der(1,i-2)=-dwasin2
3105           obrot2_der(2,i-2)= dwacos2
3106           Ug2der(1,1,i-2)= dwasin2
3107           Ug2der(1,2,i-2)=-dwacos2
3108           Ug2der(2,1,i-2)=-dwacos2
3109           Ug2der(2,2,i-2)=-dwasin2
3110         else
3111           obrot_der(1,i-2)=0.0d0
3112           obrot_der(2,i-2)=0.0d0
3113           Ugder(1,1,i-2)=0.0d0
3114           Ugder(1,2,i-2)=0.0d0
3115           Ugder(2,1,i-2)=0.0d0
3116           Ugder(2,2,i-2)=0.0d0
3117           obrot2_der(1,i-2)=0.0d0
3118           obrot2_der(2,i-2)=0.0d0
3119           Ug2der(1,1,i-2)=0.0d0
3120           Ug2der(1,2,i-2)=0.0d0
3121           Ug2der(2,1,i-2)=0.0d0
3122           Ug2der(2,2,i-2)=0.0d0
3123         endif
3124 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3125 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3126         if (i.gt.nnt+2 .and.i.lt.nct+2) then
3127           iti = itype2loc(itype(i-2))
3128         else
3129           iti=nloctyp
3130         endif
3131 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3132         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3133           iti1 = itype2loc(itype(i-1))
3134         else
3135           iti1=nloctyp
3136         endif
3137 cd        write (iout,*) '*******i',i,' iti1',iti
3138 cd        write (iout,*) 'b1',b1(:,iti)
3139 cd        write (iout,*) 'b2',b2(:,iti)
3140 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3141 c        if (i .gt. iatel_s+2) then
3142         if (i .gt. nnt+2) then
3143           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3144 #ifdef NEWCORR
3145           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3146 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3147 #endif
3148 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3149 c     &    EE(1,2,iti),EE(2,2,i)
3150           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3151           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3152 c          write(iout,*) "Macierz EUG",
3153 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3154 c     &    eug(2,2,i-2)
3155 #ifdef FOURBODY
3156           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3157      &    then
3158           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3159           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3160           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3161           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3162           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3163           endif
3164 #endif
3165         else
3166           do k=1,2
3167             Ub2(k,i-2)=0.0d0
3168             Ctobr(k,i-2)=0.0d0
3169             Dtobr2(k,i-2)=0.0d0
3170             do l=1,2
3171               EUg(l,k,i-2)=0.0d0
3172               CUg(l,k,i-2)=0.0d0
3173               DUg(l,k,i-2)=0.0d0
3174               DtUg2(l,k,i-2)=0.0d0
3175             enddo
3176           enddo
3177         endif
3178         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3179         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3180         do k=1,2
3181           muder(k,i-2)=Ub2der(k,i-2)
3182         enddo
3183 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3184         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3185           if (itype(i-1).le.ntyp) then
3186             iti1 = itype2loc(itype(i-1))
3187           else
3188             iti1=nloctyp
3189           endif
3190         else
3191           iti1=nloctyp
3192         endif
3193         do k=1,2
3194           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3195 c          mu(k,i-2)=b1(k,i-1)
3196 c          mu(k,i-2)=Ub2(k,i-2)
3197         enddo
3198 #ifdef MUOUT
3199         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3200      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3201      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3202      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3203      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3204      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3205 #endif
3206 cd        write (iout,*) 'mu1',mu1(:,i-2)
3207 cd        write (iout,*) 'mu2',mu2(:,i-2)
3208 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3209 #ifdef FOURBODY
3210         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3211      &  then
3212         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3213         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3214         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3215         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3216         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3217 C Vectors and matrices dependent on a single virtual-bond dihedral.
3218         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3219         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3220         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3221         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3222         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3223         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3224         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3225         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3226         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3227         endif
3228 #endif
3229       enddo
3230 #ifdef FOURBODY
3231 C Matrices dependent on two consecutive virtual-bond dihedrals.
3232 C The order of matrices is from left to right.
3233       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3234      &then
3235 c      do i=max0(ivec_start,2),ivec_end
3236       do i=2,nres-1
3237         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3238         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3239         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3240         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3241         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3242         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3243         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3244         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3245       enddo
3246       endif
3247 #endif
3248 #if defined(MPI) && defined(PARMAT)
3249 #ifdef DEBUG
3250 c      if (fg_rank.eq.0) then
3251         write (iout,*) "Arrays UG and UGDER before GATHER"
3252         do i=1,nres-1
3253           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3254      &     ((ug(l,k,i),l=1,2),k=1,2),
3255      &     ((ugder(l,k,i),l=1,2),k=1,2)
3256         enddo
3257         write (iout,*) "Arrays UG2 and UG2DER"
3258         do i=1,nres-1
3259           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3260      &     ((ug2(l,k,i),l=1,2),k=1,2),
3261      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3262         enddo
3263         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3264         do i=1,nres-1
3265           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3266      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3267      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3268         enddo
3269         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3270         do i=1,nres-1
3271           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3272      &     costab(i),sintab(i),costab2(i),sintab2(i)
3273         enddo
3274         write (iout,*) "Array MUDER"
3275         do i=1,nres-1
3276           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3277         enddo
3278 c      endif
3279 #endif
3280       if (nfgtasks.gt.1) then
3281         time00=MPI_Wtime()
3282 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3283 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3284 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3285 #ifdef MATGATHER
3286         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3287      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3288      &   FG_COMM1,IERR)
3289         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3290      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3291      &   FG_COMM1,IERR)
3292         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3293      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3294      &   FG_COMM1,IERR)
3295         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3296      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3297      &   FG_COMM1,IERR)
3298         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3299      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3300      &   FG_COMM1,IERR)
3301         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3302      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3303      &   FG_COMM1,IERR)
3304         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3305      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3306      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3307         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3308      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3309      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3310         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3311      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3312      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3313         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3314      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3315      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3316 #ifdef FOURBODY
3317         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3318      &  then
3319         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3320      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3321      &   FG_COMM1,IERR)
3322         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3323      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3324      &   FG_COMM1,IERR)
3325         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3326      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3327      &   FG_COMM1,IERR)
3328        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3329      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3330      &   FG_COMM1,IERR)
3331         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3332      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3333      &   FG_COMM1,IERR)
3334         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3335      &   ivec_count(fg_rank1),
3336      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3337      &   FG_COMM1,IERR)
3338         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3339      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3340      &   FG_COMM1,IERR)
3341         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3342      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3343      &   FG_COMM1,IERR)
3344         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3345      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3346      &   FG_COMM1,IERR)
3347         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3348      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3349      &   FG_COMM1,IERR)
3350         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3351      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3352      &   FG_COMM1,IERR)
3353         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3354      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3355      &   FG_COMM1,IERR)
3356         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3357      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3358      &   FG_COMM1,IERR)
3359         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3360      &   ivec_count(fg_rank1),
3361      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3362      &   FG_COMM1,IERR)
3363         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3364      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3365      &   FG_COMM1,IERR)
3366        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3367      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3368      &   FG_COMM1,IERR)
3369         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3370      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3371      &   FG_COMM1,IERR)
3372        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3373      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3374      &   FG_COMM1,IERR)
3375         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3376      &   ivec_count(fg_rank1),
3377      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3378      &   FG_COMM1,IERR)
3379         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3380      &   ivec_count(fg_rank1),
3381      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3382      &   FG_COMM1,IERR)
3383         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3384      &   ivec_count(fg_rank1),
3385      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3386      &   MPI_MAT2,FG_COMM1,IERR)
3387         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3388      &   ivec_count(fg_rank1),
3389      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3390      &   MPI_MAT2,FG_COMM1,IERR)
3391         endif
3392 #endif
3393 #else
3394 c Passes matrix info through the ring
3395       isend=fg_rank1
3396       irecv=fg_rank1-1
3397       if (irecv.lt.0) irecv=nfgtasks1-1
3398       iprev=irecv
3399       inext=fg_rank1+1
3400       if (inext.ge.nfgtasks1) inext=0
3401       do i=1,nfgtasks1-1
3402 c        write (iout,*) "isend",isend," irecv",irecv
3403 c        call flush(iout)
3404         lensend=lentyp(isend)
3405         lenrecv=lentyp(irecv)
3406 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3407 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3408 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3409 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3410 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3411 c        write (iout,*) "Gather ROTAT1"
3412 c        call flush(iout)
3413 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3414 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3415 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3416 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3417 c        write (iout,*) "Gather ROTAT2"
3418 c        call flush(iout)
3419         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3420      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3421      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3422      &   iprev,4400+irecv,FG_COMM,status,IERR)
3423 c        write (iout,*) "Gather ROTAT_OLD"
3424 c        call flush(iout)
3425         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3426      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3427      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3428      &   iprev,5500+irecv,FG_COMM,status,IERR)
3429 c        write (iout,*) "Gather PRECOMP11"
3430 c        call flush(iout)
3431         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3432      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3433      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3434      &   iprev,6600+irecv,FG_COMM,status,IERR)
3435 c        write (iout,*) "Gather PRECOMP12"
3436 c        call flush(iout)
3437 #ifdef FOURBODY
3438         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3439      &  then
3440         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3441      &   MPI_ROTAT2(lensend),inext,7700+isend,
3442      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3443      &   iprev,7700+irecv,FG_COMM,status,IERR)
3444 c        write (iout,*) "Gather PRECOMP21"
3445 c        call flush(iout)
3446         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3447      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3448      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3449      &   iprev,8800+irecv,FG_COMM,status,IERR)
3450 c        write (iout,*) "Gather PRECOMP22"
3451 c        call flush(iout)
3452         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3453      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3454      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3455      &   MPI_PRECOMP23(lenrecv),
3456      &   iprev,9900+irecv,FG_COMM,status,IERR)
3457 #endif
3458 c        write (iout,*) "Gather PRECOMP23"
3459 c        call flush(iout)
3460         endif
3461         isend=irecv
3462         irecv=irecv-1
3463         if (irecv.lt.0) irecv=nfgtasks1-1
3464       enddo
3465 #endif
3466         time_gather=time_gather+MPI_Wtime()-time00
3467       endif
3468 #ifdef DEBUG
3469 c      if (fg_rank.eq.0) then
3470         write (iout,*) "Arrays UG and UGDER"
3471         do i=1,nres-1
3472           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3473      &     ((ug(l,k,i),l=1,2),k=1,2),
3474      &     ((ugder(l,k,i),l=1,2),k=1,2)
3475         enddo
3476         write (iout,*) "Arrays UG2 and UG2DER"
3477         do i=1,nres-1
3478           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3479      &     ((ug2(l,k,i),l=1,2),k=1,2),
3480      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3481         enddo
3482         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3483         do i=1,nres-1
3484           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3485      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3486      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3487         enddo
3488         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3489         do i=1,nres-1
3490           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3491      &     costab(i),sintab(i),costab2(i),sintab2(i)
3492         enddo
3493         write (iout,*) "Array MUDER"
3494         do i=1,nres-1
3495           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3496         enddo
3497 c      endif
3498 #endif
3499 #endif
3500 cd      do i=1,nres
3501 cd        iti = itype2loc(itype(i))
3502 cd        write (iout,*) i
3503 cd        do j=1,2
3504 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3505 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3506 cd        enddo
3507 cd      enddo
3508       return
3509       end
3510 C-----------------------------------------------------------------------------
3511       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3512 C
3513 C This subroutine calculates the average interaction energy and its gradient
3514 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3515 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3516 C The potential depends both on the distance of peptide-group centers and on
3517 C the orientation of the CA-CA virtual bonds.
3518 C
3519       implicit real*8 (a-h,o-z)
3520 #ifdef MPI
3521       include 'mpif.h'
3522 #endif
3523       include 'DIMENSIONS'
3524       include 'COMMON.CONTROL'
3525       include 'COMMON.SETUP'
3526       include 'COMMON.IOUNITS'
3527       include 'COMMON.GEO'
3528       include 'COMMON.VAR'
3529       include 'COMMON.LOCAL'
3530       include 'COMMON.CHAIN'
3531       include 'COMMON.DERIV'
3532       include 'COMMON.INTERACT'
3533 #ifdef FOURBODY
3534       include 'COMMON.CONTACTS'
3535       include 'COMMON.CONTMAT'
3536 #endif
3537       include 'COMMON.CORRMAT'
3538       include 'COMMON.TORSION'
3539       include 'COMMON.VECTORS'
3540       include 'COMMON.FFIELD'
3541       include 'COMMON.TIME1'
3542       include 'COMMON.SPLITELE'
3543       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3544      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3545       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3546      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3547       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3548      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3549      &    num_conti,j1,j2
3550       double precision sslipi,sslipj,ssgradlipi,ssgradlipj
3551       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj
3552 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3553 #ifdef MOMENT
3554       double precision scal_el /1.0d0/
3555 #else
3556       double precision scal_el /0.5d0/
3557 #endif
3558 C 12/13/98
3559 C 13-go grudnia roku pamietnego...
3560       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3561      &                   0.0d0,1.0d0,0.0d0,
3562      &                   0.0d0,0.0d0,1.0d0/
3563 cd      write(iout,*) 'In EELEC'
3564 cd      do i=1,nloctyp
3565 cd        write(iout,*) 'Type',i
3566 cd        write(iout,*) 'B1',B1(:,i)
3567 cd        write(iout,*) 'B2',B2(:,i)
3568 cd        write(iout,*) 'CC',CC(:,:,i)
3569 cd        write(iout,*) 'DD',DD(:,:,i)
3570 cd        write(iout,*) 'EE',EE(:,:,i)
3571 cd      enddo
3572 cd      call check_vecgrad
3573 cd      stop
3574       if (icheckgrad.eq.1) then
3575         do i=1,nres-1
3576           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3577           do k=1,3
3578             dc_norm(k,i)=dc(k,i)*fac
3579           enddo
3580 c          write (iout,*) 'i',i,' fac',fac
3581         enddo
3582       endif
3583       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3584      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3585      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3586 c        call vec_and_deriv
3587 #ifdef TIMING
3588         time01=MPI_Wtime()
3589 #endif
3590         call set_matrices
3591 #ifdef TIMING
3592         time_mat=time_mat+MPI_Wtime()-time01
3593 #endif
3594       endif
3595 cd      do i=1,nres-1
3596 cd        write (iout,*) 'i=',i
3597 cd        do k=1,3
3598 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3599 cd        enddo
3600 cd        do k=1,3
3601 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3602 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3603 cd        enddo
3604 cd      enddo
3605       t_eelecij=0.0d0
3606       ees=0.0D0
3607       evdw1=0.0D0
3608       eel_loc=0.0d0
3609       eello_turn3=0.0d0
3610       eello_turn4=0.0d0
3611       ind=0
3612 #ifdef FOURBODY
3613       do i=1,nres
3614         num_cont_hb(i)=0
3615       enddo
3616 #endif
3617 cd      print '(a)','Enter EELEC'
3618 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3619       do i=1,nres
3620         gel_loc_loc(i)=0.0d0
3621         gcorr_loc(i)=0.0d0
3622       enddo
3623 c
3624 c
3625 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3626 C
3627 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3628 C
3629 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3630       do i=iturn3_start,iturn3_end
3631 c        if (i.le.1) cycle
3632 C        write(iout,*) "tu jest i",i
3633         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3634 C changes suggested by Ana to avoid out of bounds
3635 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3636 c     & .or.((i+4).gt.nres)
3637 c     & .or.((i-1).le.0)
3638 C end of changes by Ana
3639      &  .or. itype(i+2).eq.ntyp1
3640      &  .or. itype(i+3).eq.ntyp1) cycle
3641 C Adam: Instructions below will switch off existing interactions
3642 c        if(i.gt.1)then
3643 c          if(itype(i-1).eq.ntyp1)cycle
3644 c        end if
3645 c        if(i.LT.nres-3)then
3646 c          if (itype(i+4).eq.ntyp1) cycle
3647 c        end if
3648         dxi=dc(1,i)
3649         dyi=dc(2,i)
3650         dzi=dc(3,i)
3651         dx_normi=dc_norm(1,i)
3652         dy_normi=dc_norm(2,i)
3653         dz_normi=dc_norm(3,i)
3654         xmedi=c(1,i)+0.5d0*dxi
3655         ymedi=c(2,i)+0.5d0*dyi
3656         zmedi=c(3,i)+0.5d0*dzi
3657         call to_box(xmedi,ymedi,zmedi)
3658         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3659         num_conti=0
3660         call eelecij(i,i+2,ees,evdw1,eel_loc)
3661         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3662 #ifdef FOURBODY
3663         num_cont_hb(i)=num_conti
3664 #endif
3665       enddo
3666       do i=iturn4_start,iturn4_end
3667         if (i.lt.1) cycle
3668         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3669 C changes suggested by Ana to avoid out of bounds
3670 c     & .or.((i+5).gt.nres)
3671 c     & .or.((i-1).le.0)
3672 C end of changes suggested by Ana
3673      &    .or. itype(i+3).eq.ntyp1
3674      &    .or. itype(i+4).eq.ntyp1
3675 c     &    .or. itype(i+5).eq.ntyp1
3676 c     &    .or. itype(i).eq.ntyp1
3677 c     &    .or. itype(i-1).eq.ntyp1
3678      &                             ) cycle
3679         dxi=dc(1,i)
3680         dyi=dc(2,i)
3681         dzi=dc(3,i)
3682         dx_normi=dc_norm(1,i)
3683         dy_normi=dc_norm(2,i)
3684         dz_normi=dc_norm(3,i)
3685         xmedi=c(1,i)+0.5d0*dxi
3686         ymedi=c(2,i)+0.5d0*dyi
3687         zmedi=c(3,i)+0.5d0*dzi
3688 C Return atom into box, boxxsize is size of box in x dimension
3689 c  194   continue
3690 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3691 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3692 C Condition for being inside the proper box
3693 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3694 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3695 c        go to 194
3696 c        endif
3697 c  195   continue
3698 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3699 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3700 C Condition for being inside the proper box
3701 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3702 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3703 c        go to 195
3704 c        endif
3705 c  196   continue
3706 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3707 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3708 C Condition for being inside the proper box
3709 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3710 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3711 c        go to 196
3712 c        endif
3713         call to_box(xmedi,ymedi,zmedi)
3714         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3715 #ifdef FOURBODY
3716         num_conti=num_cont_hb(i)
3717 #endif
3718 c        write(iout,*) "JESTEM W PETLI"
3719         call eelecij(i,i+3,ees,evdw1,eel_loc)
3720         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3721      &   call eturn4(i,eello_turn4)
3722 #ifdef FOURBODY
3723         num_cont_hb(i)=num_conti
3724 #endif
3725       enddo   ! i
3726 C Loop over all neighbouring boxes
3727 C      do xshift=-1,1
3728 C      do yshift=-1,1
3729 C      do zshift=-1,1
3730 c
3731 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3732 c
3733 CTU KURWA
3734 c      do i=iatel_s,iatel_e
3735       do ikont=g_listpp_start,g_listpp_end
3736         i=newcontlistppi(ikont)
3737         j=newcontlistppj(ikont)
3738 C        do i=75,75
3739 c        if (i.le.1) cycle
3740         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3741 C changes suggested by Ana to avoid out of bounds
3742 c     & .or.((i+2).gt.nres)
3743 c     & .or.((i-1).le.0)
3744 C end of changes by Ana
3745 c     &  .or. itype(i+2).eq.ntyp1
3746 c     &  .or. itype(i-1).eq.ntyp1
3747      &                ) cycle
3748         dxi=dc(1,i)
3749         dyi=dc(2,i)
3750         dzi=dc(3,i)
3751         dx_normi=dc_norm(1,i)
3752         dy_normi=dc_norm(2,i)
3753         dz_normi=dc_norm(3,i)
3754         xmedi=c(1,i)+0.5d0*dxi
3755         ymedi=c(2,i)+0.5d0*dyi
3756         zmedi=c(3,i)+0.5d0*dzi
3757         call to_box(xmedi,ymedi,zmedi)
3758         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3759 C          xmedi=xmedi+xshift*boxxsize
3760 C          ymedi=ymedi+yshift*boxysize
3761 C          zmedi=zmedi+zshift*boxzsize
3762
3763 C Return tom into box, boxxsize is size of box in x dimension
3764 c  164   continue
3765 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3766 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3767 C Condition for being inside the proper box
3768 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3769 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3770 c        go to 164
3771 c        endif
3772 c  165   continue
3773 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3774 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3775 C Condition for being inside the proper box
3776 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3777 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3778 c        go to 165
3779 c        endif
3780 c  166   continue
3781 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3782 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3783 cC Condition for being inside the proper box
3784 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3785 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3786 c        go to 166
3787 c        endif
3788
3789 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3790 #ifdef FOURBODY
3791         num_conti=num_cont_hb(i)
3792 #endif
3793 C I TU KURWA
3794 c        do j=ielstart(i),ielend(i)
3795 C          do j=16,17
3796 C          write (iout,*) i,j
3797 C         if (j.le.1) cycle
3798         if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3799 C changes suggested by Ana to avoid out of bounds
3800 c     & .or.((j+2).gt.nres)
3801 c     & .or.((j-1).le.0)
3802 C end of changes by Ana
3803 c     & .or.itype(j+2).eq.ntyp1
3804 c     & .or.itype(j-1).eq.ntyp1
3805      &) cycle
3806         call eelecij(i,j,ees,evdw1,eel_loc)
3807 c        enddo ! j
3808 #ifdef FOURBODY
3809         num_cont_hb(i)=num_conti
3810 #endif
3811       enddo   ! i
3812 C     enddo   ! zshift
3813 C      enddo   ! yshift
3814 C      enddo   ! xshift
3815
3816 c      write (iout,*) "Number of loop steps in EELEC:",ind
3817 cd      do i=1,nres
3818 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3819 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3820 cd      enddo
3821 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3822 ccc      eel_loc=eel_loc+eello_turn3
3823 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3824       return
3825       end
3826 C-------------------------------------------------------------------------------
3827       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3828       implicit none
3829       include 'DIMENSIONS'
3830 #ifdef MPI
3831       include "mpif.h"
3832 #endif
3833       include 'COMMON.CONTROL'
3834       include 'COMMON.IOUNITS'
3835       include 'COMMON.GEO'
3836       include 'COMMON.VAR'
3837       include 'COMMON.LOCAL'
3838       include 'COMMON.CHAIN'
3839       include 'COMMON.DERIV'
3840       include 'COMMON.INTERACT'
3841 #ifdef FOURBODY
3842       include 'COMMON.CONTACTS'
3843       include 'COMMON.CONTMAT'
3844 #endif
3845       include 'COMMON.CORRMAT'
3846       include 'COMMON.TORSION'
3847       include 'COMMON.VECTORS'
3848       include 'COMMON.FFIELD'
3849       include 'COMMON.TIME1'
3850       include 'COMMON.SPLITELE'
3851       include 'COMMON.SHIELD'
3852       double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3853      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3854       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3855      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3856      &    gmuij2(4),gmuji2(4)
3857       double precision dxi,dyi,dzi
3858       double precision dx_normi,dy_normi,dz_normi,aux
3859       integer j1,j2,lll,num_conti
3860       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3861      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3862      &    num_conti,j1,j2
3863       integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3864       double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3865       double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3866       double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3867      &  rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3868      &  evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3869      &  ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3870      &  a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3871      &  ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3872      &  ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3873      &  ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3874       double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3875       double precision xmedi,ymedi,zmedi
3876       double precision sscale,sscagrad,scalar
3877       double precision boxshift
3878       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij,
3879      & faclipij2
3880       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3881 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3882 #ifdef MOMENT
3883       double precision scal_el /1.0d0/
3884 #else
3885       double precision scal_el /0.5d0/
3886 #endif
3887 C 12/13/98
3888 C 13-go grudnia roku pamietnego...
3889       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3890      &                   0.0d0,1.0d0,0.0d0,
3891      &                   0.0d0,0.0d0,1.0d0/
3892 c          time00=MPI_Wtime()
3893 cd      write (iout,*) "eelecij",i,j
3894 c          ind=ind+1
3895 c          write (iout,*) "lipscale",lipscale
3896           iteli=itel(i)
3897           itelj=itel(j)
3898           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3899           aaa=app(iteli,itelj)
3900           bbb=bpp(iteli,itelj)
3901           ael6i=ael6(iteli,itelj)
3902           ael3i=ael3(iteli,itelj)
3903           dxj=dc(1,j)
3904           dyj=dc(2,j)
3905           dzj=dc(3,j)
3906           dx_normj=dc_norm(1,j)
3907           dy_normj=dc_norm(2,j)
3908           dz_normj=dc_norm(3,j)
3909 C          xj=c(1,j)+0.5D0*dxj-xmedi
3910 C          yj=c(2,j)+0.5D0*dyj-ymedi
3911 C          zj=c(3,j)+0.5D0*dzj-zmedi
3912           xj=c(1,j)+0.5D0*dxj
3913           yj=c(2,j)+0.5D0*dyj
3914           zj=c(3,j)+0.5D0*dzj
3915           call to_box(xj,yj,zj)
3916           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
3917           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
3918           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3919           xj=boxshift(xj-xmedi,boxxsize)
3920           yj=boxshift(yj-ymedi,boxysize)
3921           zj=boxshift(zj-zmedi,boxzsize)
3922 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3923 c  174   continue
3924           rij=xj*xj+yj*yj+zj*zj
3925
3926           sss=sscale(dsqrt(rij),r_cut_int)
3927           if (sss.eq.0.0d0) return
3928           sssgrad=sscagrad(dsqrt(rij),r_cut_int)
3929 c            if (sss.gt.0.0d0) then
3930           rrmij=1.0D0/rij
3931           rij=dsqrt(rij)
3932           rmij=1.0D0/rij
3933           r3ij=rrmij*rmij
3934           r6ij=r3ij*r3ij
3935           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3936           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3937           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3938           fac=cosa-3.0D0*cosb*cosg
3939           ev1=aaa*r6ij*r6ij
3940 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3941           if (j.eq.i+2) ev1=scal_el*ev1
3942           ev2=bbb*r6ij
3943           fac3=ael6i*r6ij
3944           fac4=ael3i*r3ij
3945           evdwij=(ev1+ev2)
3946           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3947           el2=fac4*fac
3948 C MARYSIA
3949 C          eesij=(el1+el2)
3950 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3951           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3952           if (shield_mode.gt.0) then
3953 C          fac_shield(i)=0.4
3954 C          fac_shield(j)=0.6
3955           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3956           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3957           eesij=(el1+el2)
3958           ees=ees+eesij*sss*faclipij2
3959           else
3960           fac_shield(i)=1.0
3961           fac_shield(j)=1.0
3962           eesij=(el1+el2)
3963           ees=ees+eesij*sss*faclipij2
3964           endif
3965           ees=ees
3966           evdw1=evdw1+evdwij*sss*faclipij2
3967 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3968 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3969 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3970 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3971
3972           if (energy_dec) then
3973             write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
3974      &        'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
3975             write (iout,'(a6,2i5,0pf7.3,6f8.5)') 'ees',i,j,eesij,
3976      &        fac_shield(i),fac_shield(j),sslipi,sslipj,faclipij,
3977      &        faclipij2
3978           endif
3979
3980 C
3981 C Calculate contributions to the Cartesian gradient.
3982 C
3983 #ifdef SPLITELE
3984           facvdw=-6*rrmij*(ev1+evdwij)*sss
3985           facel=-3*rrmij*(el1+eesij)
3986           fac1=fac
3987           erij(1)=xj*rmij
3988           erij(2)=yj*rmij
3989           erij(3)=zj*rmij
3990
3991 *
3992 * Radial derivatives. First process both termini of the fragment (i,j)
3993 *
3994           aux=(facel*sss+rmij*sssgrad*eesij)*faclipij2
3995           ggg(1)=aux*xj
3996           ggg(2)=aux*yj
3997           ggg(3)=aux*zj
3998           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3999      &  (shield_mode.gt.0)) then
4000 C          print *,i,j
4001           do ilist=1,ishield_list(i)
4002            iresshield=shield_list(ilist,i)
4003            do k=1,3
4004            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4005      &      *2.0
4006            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4007      &              rlocshield
4008      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4009             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4010 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4011 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4012 C             if (iresshield.gt.i) then
4013 C               do ishi=i+1,iresshield-1
4014 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4015 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4016 C
4017 C              enddo
4018 C             else
4019 C               do ishi=iresshield,i
4020 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4021 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4022 C
4023 C               enddo
4024 C              endif
4025            enddo
4026           enddo
4027           do ilist=1,ishield_list(j)
4028            iresshield=shield_list(ilist,j)
4029            do k=1,3
4030            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4031      &     *2.0*sss
4032            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4033      &              rlocshield
4034      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
4035            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4036
4037 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4038 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4039 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4040 C             if (iresshield.gt.j) then
4041 C               do ishi=j+1,iresshield-1
4042 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4043 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4044 C
4045 C               enddo
4046 C            else
4047 C               do ishi=iresshield,j
4048 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4049 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4050 C               enddo
4051 C              endif
4052            enddo
4053           enddo
4054
4055           do k=1,3
4056             gshieldc(k,i)=gshieldc(k,i)+
4057      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4058             gshieldc(k,j)=gshieldc(k,j)+
4059      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4060             gshieldc(k,i-1)=gshieldc(k,i-1)+
4061      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4062             gshieldc(k,j-1)=gshieldc(k,j-1)+
4063      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4064
4065            enddo
4066            endif
4067 c          do k=1,3
4068 c            ghalf=0.5D0*ggg(k)
4069 c            gelc(k,i)=gelc(k,i)+ghalf
4070 c            gelc(k,j)=gelc(k,j)+ghalf
4071 c          enddo
4072 c 9/28/08 AL Gradient compotents will be summed only at the end
4073 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4074           do k=1,3
4075             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4076             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4077           enddo
4078           gelc_long(3,j)=gelc_long(3,j)+
4079      &      ssgradlipj*eesij/2.0d0*lipscale**2*sss
4080
4081           gelc_long(3,i)=gelc_long(3,i)+
4082      &      ssgradlipi*eesij/2.0d0*lipscale**2*sss
4083
4084
4085 *
4086 * Loop over residues i+1 thru j-1.
4087 *
4088 cgrad          do k=i+1,j-1
4089 cgrad            do l=1,3
4090 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4091 cgrad            enddo
4092 cgrad          enddo
4093           facvdw=(facvdw+sssgrad*rmij*evdwij)*faclipij2
4094           ggg(1)=facvdw*xj
4095           ggg(2)=facvdw*yj
4096           ggg(3)=facvdw*zj
4097 c          do k=1,3
4098 c            ghalf=0.5D0*ggg(k)
4099 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4100 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4101 c          enddo
4102 c 9/28/08 AL Gradient compotents will be summed only at the end
4103           do k=1,3
4104             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4105             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4106           enddo
4107 !C Lipidic part for scaling weight
4108           gvdwpp(3,j)=gvdwpp(3,j)+
4109      &      sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4110           gvdwpp(3,i)=gvdwpp(3,i)+
4111      &      sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4112 *
4113 * Loop over residues i+1 thru j-1.
4114 *
4115 cgrad          do k=i+1,j-1
4116 cgrad            do l=1,3
4117 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4118 cgrad            enddo
4119 cgrad          enddo
4120 #else
4121 C MARYSIA
4122           facvdw=(ev1+evdwij)*faclipij2
4123           facel=(el1+eesij)
4124           fac1=fac
4125           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4126      &       +(evdwij+eesij)*sssgrad*rrmij
4127           erij(1)=xj*rmij
4128           erij(2)=yj*rmij
4129           erij(3)=zj*rmij
4130 *
4131 * Radial derivatives. First process both termini of the fragment (i,j)
4132 *
4133           ggg(1)=fac*xj
4134 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4135           ggg(2)=fac*yj
4136 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4137           ggg(3)=fac*zj
4138 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4139 c          do k=1,3
4140 c            ghalf=0.5D0*ggg(k)
4141 c            gelc(k,i)=gelc(k,i)+ghalf
4142 c            gelc(k,j)=gelc(k,j)+ghalf
4143 c          enddo
4144 c 9/28/08 AL Gradient compotents will be summed only at the end
4145           do k=1,3
4146             gelc_long(k,j)=gelc(k,j)+ggg(k)
4147             gelc_long(k,i)=gelc(k,i)-ggg(k)
4148           enddo
4149 *
4150 * Loop over residues i+1 thru j-1.
4151 *
4152 cgrad          do k=i+1,j-1
4153 cgrad            do l=1,3
4154 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4155 cgrad            enddo
4156 cgrad          enddo
4157 c 9/28/08 AL Gradient compotents will be summed only at the end
4158           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4159           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4160           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4161           do k=1,3
4162             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4163             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4164           enddo
4165           gvdwpp(3,j)=gvdwpp(3,j)+
4166      &      sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4167           gvdwpp(3,i)=gvdwpp(3,i)+
4168      &      sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4169 #endif
4170 *
4171 * Angular part
4172 *
4173           ecosa=2.0D0*fac3*fac1+fac4
4174           fac4=-3.0D0*fac4
4175           fac3=-6.0D0*fac3
4176           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4177           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4178           do k=1,3
4179             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4180             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4181           enddo
4182 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4183 cd   &          (dcosg(k),k=1,3)
4184           do k=1,3
4185             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4186      &      fac_shield(i)**2*fac_shield(j)**2*sss*faclipij2
4187           enddo
4188 c          do k=1,3
4189 c            ghalf=0.5D0*ggg(k)
4190 c            gelc(k,i)=gelc(k,i)+ghalf
4191 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4192 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4193 c            gelc(k,j)=gelc(k,j)+ghalf
4194 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4195 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4196 c          enddo
4197 cgrad          do k=i+1,j-1
4198 cgrad            do l=1,3
4199 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4200 cgrad            enddo
4201 cgrad          enddo
4202 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4203           do k=1,3
4204             gelc(k,i)=gelc(k,i)
4205      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4206      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4207      &           *fac_shield(i)**2*fac_shield(j)**2*faclipij2
4208             gelc(k,j)=gelc(k,j)
4209      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4210      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4211      &           *fac_shield(i)**2*fac_shield(j)**2*faclipij2
4212             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4213             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4214           enddo
4215 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4216
4217 C MARYSIA
4218 c          endif !sscale
4219           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4220      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4221      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4222 C
4223 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4224 C   energy of a peptide unit is assumed in the form of a second-order
4225 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4226 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4227 C   are computed for EVERY pair of non-contiguous peptide groups.
4228 C
4229
4230           if (j.lt.nres-1) then
4231             j1=j+1
4232             j2=j-1
4233           else
4234             j1=j-1
4235             j2=j-2
4236           endif
4237           kkk=0
4238           lll=0
4239           do k=1,2
4240             do l=1,2
4241               kkk=kkk+1
4242               muij(kkk)=mu(k,i)*mu(l,j)
4243 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4244 #ifdef NEWCORR
4245              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4246 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4247              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4248              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4249 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4250              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4251 #endif
4252             enddo
4253           enddo
4254 #ifdef DEBUG
4255           write (iout,*) 'EELEC: i',i,' j',j
4256           write (iout,*) 'j',j,' j1',j1,' j2',j2
4257           write(iout,*) 'muij',muij
4258 #endif
4259           ury=scalar(uy(1,i),erij)
4260           urz=scalar(uz(1,i),erij)
4261           vry=scalar(uy(1,j),erij)
4262           vrz=scalar(uz(1,j),erij)
4263           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4264           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4265           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4266           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4267           fac=dsqrt(-ael6i)*r3ij
4268 #ifdef DEBUG
4269           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4270           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4271      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4272      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4273      &      "uzvz",scalar(uz(1,i),uz(1,j))
4274           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4275           write (iout,*) "fac",fac
4276 #endif
4277           a22=a22*fac
4278           a23=a23*fac
4279           a32=a32*fac
4280           a33=a33*fac
4281 #ifdef DEBUG
4282           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4283 #endif
4284 #undef DEBUG
4285 cd          write (iout,'(4i5,4f10.5)')
4286 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4287 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4288 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4289 cd     &      uy(:,j),uz(:,j)
4290 cd          write (iout,'(4f10.5)')
4291 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4292 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4293 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4294 cd           write (iout,'(9f10.5/)')
4295 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4296 C Derivatives of the elements of A in virtual-bond vectors
4297           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4298           do k=1,3
4299             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4300             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4301             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4302             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4303             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4304             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4305             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4306             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4307             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4308             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4309             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4310             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4311           enddo
4312 C Compute radial contributions to the gradient
4313           facr=-3.0d0*rrmij
4314           a22der=a22*facr
4315           a23der=a23*facr
4316           a32der=a32*facr
4317           a33der=a33*facr
4318           agg(1,1)=a22der*xj
4319           agg(2,1)=a22der*yj
4320           agg(3,1)=a22der*zj
4321           agg(1,2)=a23der*xj
4322           agg(2,2)=a23der*yj
4323           agg(3,2)=a23der*zj
4324           agg(1,3)=a32der*xj
4325           agg(2,3)=a32der*yj
4326           agg(3,3)=a32der*zj
4327           agg(1,4)=a33der*xj
4328           agg(2,4)=a33der*yj
4329           agg(3,4)=a33der*zj
4330 C Add the contributions coming from er
4331           fac3=-3.0d0*fac
4332           do k=1,3
4333             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4334             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4335             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4336             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4337           enddo
4338           do k=1,3
4339 C Derivatives in DC(i)
4340 cgrad            ghalf1=0.5d0*agg(k,1)
4341 cgrad            ghalf2=0.5d0*agg(k,2)
4342 cgrad            ghalf3=0.5d0*agg(k,3)
4343 cgrad            ghalf4=0.5d0*agg(k,4)
4344             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4345      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4346             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4347      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4348             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4349      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4350             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4351      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4352 C Derivatives in DC(i+1)
4353             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4354      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4355             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4356      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4357             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4358      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4359             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4360      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4361 C Derivatives in DC(j)
4362             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4363      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4364             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4365      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4366             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4367      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4368             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4369      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4370 C Derivatives in DC(j+1) or DC(nres-1)
4371             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4372      &      -3.0d0*vryg(k,3)*ury)
4373             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4374      &      -3.0d0*vrzg(k,3)*ury)
4375             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4376      &      -3.0d0*vryg(k,3)*urz)
4377             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4378      &      -3.0d0*vrzg(k,3)*urz)
4379 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4380 cgrad              do l=1,4
4381 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4382 cgrad              enddo
4383 cgrad            endif
4384           enddo
4385           acipa(1,1)=a22
4386           acipa(1,2)=a23
4387           acipa(2,1)=a32
4388           acipa(2,2)=a33
4389           a22=-a22
4390           a23=-a23
4391           do l=1,2
4392             do k=1,3
4393               agg(k,l)=-agg(k,l)
4394               aggi(k,l)=-aggi(k,l)
4395               aggi1(k,l)=-aggi1(k,l)
4396               aggj(k,l)=-aggj(k,l)
4397               aggj1(k,l)=-aggj1(k,l)
4398             enddo
4399           enddo
4400           if (j.lt.nres-1) then
4401             a22=-a22
4402             a32=-a32
4403             do l=1,3,2
4404               do k=1,3
4405                 agg(k,l)=-agg(k,l)
4406                 aggi(k,l)=-aggi(k,l)
4407                 aggi1(k,l)=-aggi1(k,l)
4408                 aggj(k,l)=-aggj(k,l)
4409                 aggj1(k,l)=-aggj1(k,l)
4410               enddo
4411             enddo
4412           else
4413             a22=-a22
4414             a23=-a23
4415             a32=-a32
4416             a33=-a33
4417             do l=1,4
4418               do k=1,3
4419                 agg(k,l)=-agg(k,l)
4420                 aggi(k,l)=-aggi(k,l)
4421                 aggi1(k,l)=-aggi1(k,l)
4422                 aggj(k,l)=-aggj(k,l)
4423                 aggj1(k,l)=-aggj1(k,l)
4424               enddo
4425             enddo
4426           endif
4427           ENDIF ! WCORR
4428           IF (wel_loc.gt.0.0d0) THEN
4429 C Contribution to the local-electrostatic energy coming from the i-j pair
4430           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4431      &     +a33*muij(4)
4432 #ifdef DEBUG
4433           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4434      &     " a33",a33
4435           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4436      &     " wel_loc",wel_loc
4437 #endif
4438           if (shield_mode.eq.0) then
4439            fac_shield(i)=1.0
4440            fac_shield(j)=1.0
4441 C          else
4442 C           fac_shield(i)=0.4
4443 C           fac_shield(j)=0.6
4444           endif
4445           eel_loc_ij=eel_loc_ij
4446      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4447 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4448 c     &            'eelloc',i,j,eel_loc_ij
4449 C Now derivative over eel_loc
4450           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4451      &  (shield_mode.gt.0)) then
4452 C          print *,i,j
4453
4454           do ilist=1,ishield_list(i)
4455            iresshield=shield_list(ilist,i)
4456            do k=1,3
4457            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4458      &                                          /fac_shield(i)
4459 C     &      *2.0
4460            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4461      &              rlocshield
4462      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4463             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4464      &      +rlocshield
4465            enddo
4466           enddo
4467           do ilist=1,ishield_list(j)
4468            iresshield=shield_list(ilist,j)
4469            do k=1,3
4470            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4471      &                                       /fac_shield(j)
4472 C     &     *2.0
4473            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4474      &              rlocshield
4475      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4476            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4477      &             +rlocshield
4478
4479            enddo
4480           enddo
4481
4482           do k=1,3
4483             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4484      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4485             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4486      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4487             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4488      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4489             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4490      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4491            enddo
4492            endif
4493
4494
4495 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4496 c     &                     ' eel_loc_ij',eel_loc_ij
4497 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4498 C Calculate patrial derivative for theta angle
4499 #ifdef NEWCORR
4500          geel_loc_ij=(a22*gmuij1(1)
4501      &     +a23*gmuij1(2)
4502      &     +a32*gmuij1(3)
4503      &     +a33*gmuij1(4))
4504      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4505 c         write(iout,*) "derivative over thatai"
4506 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4507 c     &   a33*gmuij1(4)
4508          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4509      &      geel_loc_ij*wel_loc
4510 c         write(iout,*) "derivative over thatai-1"
4511 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4512 c     &   a33*gmuij2(4)
4513          geel_loc_ij=
4514      &     a22*gmuij2(1)
4515      &     +a23*gmuij2(2)
4516      &     +a32*gmuij2(3)
4517      &     +a33*gmuij2(4)
4518          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4519      &      geel_loc_ij*wel_loc
4520      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4521
4522 c  Derivative over j residue
4523          geel_loc_ji=a22*gmuji1(1)
4524      &     +a23*gmuji1(2)
4525      &     +a32*gmuji1(3)
4526      &     +a33*gmuji1(4)
4527 c         write(iout,*) "derivative over thataj"
4528 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4529 c     &   a33*gmuji1(4)
4530
4531         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4532      &      geel_loc_ji*wel_loc
4533      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4534
4535          geel_loc_ji=
4536      &     +a22*gmuji2(1)
4537      &     +a23*gmuji2(2)
4538      &     +a32*gmuji2(3)
4539      &     +a33*gmuji2(4)
4540 c         write(iout,*) "derivative over thataj-1"
4541 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4542 c     &   a33*gmuji2(4)
4543          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4544      &      geel_loc_ji*wel_loc
4545      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4546 #endif
4547 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4548
4549           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4550      &            'eelloc',i,j,eel_loc_ij
4551 c           if (eel_loc_ij.ne.0)
4552 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4553 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4554
4555           eel_loc=eel_loc+eel_loc_ij
4556 C Partial derivatives in virtual-bond dihedral angles gamma
4557           if (i.gt.1)
4558      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4559      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4560      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4561      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4562
4563           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4564      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4565      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4566      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4567 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4568           aux=eel_loc_ij/sss*sssgrad*rmij
4569           ggg(1)=aux*xj
4570           ggg(2)=aux*yj
4571           ggg(3)=aux*zj
4572           do l=1,3
4573             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4574      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4575      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4576             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4577             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4578 cgrad            ghalf=0.5d0*ggg(l)
4579 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4580 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4581           enddo
4582           gel_loc_long(3,j)=gel_loc_long(3,j)+
4583      &      ssgradlipj*eel_loc_ij/2.0d0*lipscale/faclipij
4584
4585           gel_loc_long(3,i)=gel_loc_long(3,i)+
4586      &      ssgradlipi*eel_loc_ij/2.0d0*lipscale/faclipij
4587
4588 cgrad          do k=i+1,j2
4589 cgrad            do l=1,3
4590 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4591 cgrad            enddo
4592 cgrad          enddo
4593 C Remaining derivatives of eello
4594           do l=1,3
4595             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4596      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4597      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4598
4599             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4600      &        aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4601      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4602
4603             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4604      &        aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4605      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4606
4607             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4608      &        aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4609      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4610
4611           enddo
4612           ENDIF
4613 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4614 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4615 #ifdef FOURBODY
4616           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4617      &       .and. num_conti.le.maxconts) then
4618 c            write (iout,*) i,j," entered corr"
4619 C
4620 C Calculate the contact function. The ith column of the array JCONT will
4621 C contain the numbers of atoms that make contacts with the atom I (of numbers
4622 C greater than I). The arrays FACONT and GACONT will contain the values of
4623 C the contact function and its derivative.
4624 c           r0ij=1.02D0*rpp(iteli,itelj)
4625 c           r0ij=1.11D0*rpp(iteli,itelj)
4626             r0ij=2.20D0*rpp(iteli,itelj)
4627 c           r0ij=1.55D0*rpp(iteli,itelj)
4628             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4629             if (fcont.gt.0.0D0) then
4630               num_conti=num_conti+1
4631               if (num_conti.gt.maxconts) then
4632                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4633      &                         ' will skip next contacts for this conf.'
4634               else
4635                 jcont_hb(num_conti,i)=j
4636 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4637 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4638                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4639      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4640 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4641 C  terms.
4642                 d_cont(num_conti,i)=rij
4643 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4644 C     --- Electrostatic-interaction matrix ---
4645                 a_chuj(1,1,num_conti,i)=a22
4646                 a_chuj(1,2,num_conti,i)=a23
4647                 a_chuj(2,1,num_conti,i)=a32
4648                 a_chuj(2,2,num_conti,i)=a33
4649 C     --- Gradient of rij
4650                 do kkk=1,3
4651                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4652                 enddo
4653                 kkll=0
4654                 do k=1,2
4655                   do l=1,2
4656                     kkll=kkll+1
4657                     do m=1,3
4658                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4659                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4660                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4661                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4662                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4663                     enddo
4664                   enddo
4665                 enddo
4666                 ENDIF
4667                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4668 C Calculate contact energies
4669                 cosa4=4.0D0*cosa
4670                 wij=cosa-3.0D0*cosb*cosg
4671                 cosbg1=cosb+cosg
4672                 cosbg2=cosb-cosg
4673 c               fac3=dsqrt(-ael6i)/r0ij**3
4674                 fac3=dsqrt(-ael6i)*r3ij
4675 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4676                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4677                 if (ees0tmp.gt.0) then
4678                   ees0pij=dsqrt(ees0tmp)
4679                 else
4680                   ees0pij=0
4681                 endif
4682 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4683                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4684                 if (ees0tmp.gt.0) then
4685                   ees0mij=dsqrt(ees0tmp)
4686                 else
4687                   ees0mij=0
4688                 endif
4689 c               ees0mij=0.0D0
4690                 if (shield_mode.eq.0) then
4691                 fac_shield(i)=1.0d0
4692                 fac_shield(j)=1.0d0
4693                 else
4694                 ees0plist(num_conti,i)=j
4695 C                fac_shield(i)=0.4d0
4696 C                fac_shield(j)=0.6d0
4697                 endif
4698                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4699      &          *fac_shield(i)*fac_shield(j)*sss
4700                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4701      &          *fac_shield(i)*fac_shield(j)*sss
4702 C Diagnostics. Comment out or remove after debugging!
4703 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4704 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4705 c               ees0m(num_conti,i)=0.0D0
4706 C End diagnostics.
4707 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4708 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4709 C Angular derivatives of the contact function
4710                 ees0pij1=fac3/ees0pij
4711                 ees0mij1=fac3/ees0mij
4712                 fac3p=-3.0D0*fac3*rrmij
4713                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4714                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4715 c               ees0mij1=0.0D0
4716                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4717                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4718                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4719                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4720                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4721                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4722                 ecosap=ecosa1+ecosa2
4723                 ecosbp=ecosb1+ecosb2
4724                 ecosgp=ecosg1+ecosg2
4725                 ecosam=ecosa1-ecosa2
4726                 ecosbm=ecosb1-ecosb2
4727                 ecosgm=ecosg1-ecosg2
4728 C Diagnostics
4729 c               ecosap=ecosa1
4730 c               ecosbp=ecosb1
4731 c               ecosgp=ecosg1
4732 c               ecosam=0.0D0
4733 c               ecosbm=0.0D0
4734 c               ecosgm=0.0D0
4735 C End diagnostics
4736                 facont_hb(num_conti,i)=fcont
4737                 fprimcont=fprimcont/rij
4738 cd              facont_hb(num_conti,i)=1.0D0
4739 C Following line is for diagnostics.
4740 cd              fprimcont=0.0D0
4741                 do k=1,3
4742                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4743                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4744                 enddo
4745                 do k=1,3
4746                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4747                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4748                 enddo
4749                 gggp(1)=gggp(1)+ees0pijp*xj
4750      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4751                 gggp(2)=gggp(2)+ees0pijp*yj
4752      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4753                 gggp(3)=gggp(3)+ees0pijp*zj
4754      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4755                 gggm(1)=gggm(1)+ees0mijp*xj
4756      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4757                 gggm(2)=gggm(2)+ees0mijp*yj
4758      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4759                 gggm(3)=gggm(3)+ees0mijp*zj
4760      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4761 C Derivatives due to the contact function
4762                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4763                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4764                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4765                 do k=1,3
4766 c
4767 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4768 c          following the change of gradient-summation algorithm.
4769 c
4770 cgrad                  ghalfp=0.5D0*gggp(k)
4771 cgrad                  ghalfm=0.5D0*gggm(k)
4772                   gacontp_hb1(k,num_conti,i)=!ghalfp
4773      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4774      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4775      &          *fac_shield(i)*fac_shield(j)*sss
4776
4777                   gacontp_hb2(k,num_conti,i)=!ghalfp
4778      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4779      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4780      &          *fac_shield(i)*fac_shield(j)*sss
4781
4782                   gacontp_hb3(k,num_conti,i)=gggp(k)
4783      &          *fac_shield(i)*fac_shield(j)*sss
4784
4785                   gacontm_hb1(k,num_conti,i)=!ghalfm
4786      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4787      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4788      &          *fac_shield(i)*fac_shield(j)*sss
4789
4790                   gacontm_hb2(k,num_conti,i)=!ghalfm
4791      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4792      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4793      &          *fac_shield(i)*fac_shield(j)*sss
4794
4795                   gacontm_hb3(k,num_conti,i)=gggm(k)
4796      &          *fac_shield(i)*fac_shield(j)*sss
4797
4798                 enddo
4799 C Diagnostics. Comment out or remove after debugging!
4800 cdiag           do k=1,3
4801 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4802 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4803 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4804 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4805 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4806 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4807 cdiag           enddo
4808               ENDIF ! wcorr
4809               endif  ! num_conti.le.maxconts
4810             endif  ! fcont.gt.0
4811           endif    ! j.gt.i+1
4812 #endif
4813           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4814             do k=1,4
4815               do l=1,3
4816                 ghalf=0.5d0*agg(l,k)
4817                 aggi(l,k)=aggi(l,k)+ghalf
4818                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4819                 aggj(l,k)=aggj(l,k)+ghalf
4820               enddo
4821             enddo
4822             if (j.eq.nres-1 .and. i.lt.j-2) then
4823               do k=1,4
4824                 do l=1,3
4825                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4826                 enddo
4827               enddo
4828             endif
4829           endif
4830 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4831       return
4832       end
4833 C-----------------------------------------------------------------------------
4834       subroutine eturn3(i,eello_turn3)
4835 C Third- and fourth-order contributions from turns
4836       implicit real*8 (a-h,o-z)
4837       include 'DIMENSIONS'
4838       include 'COMMON.IOUNITS'
4839       include 'COMMON.GEO'
4840       include 'COMMON.VAR'
4841       include 'COMMON.LOCAL'
4842       include 'COMMON.CHAIN'
4843       include 'COMMON.DERIV'
4844       include 'COMMON.INTERACT'
4845       include 'COMMON.CORRMAT'
4846       include 'COMMON.TORSION'
4847       include 'COMMON.VECTORS'
4848       include 'COMMON.FFIELD'
4849       include 'COMMON.CONTROL'
4850       include 'COMMON.SHIELD'
4851       dimension ggg(3)
4852       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4853      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4854      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4855      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4856      &  auxgmat2(2,2),auxgmatt2(2,2)
4857       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4858      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4859       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4860      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4861      &    num_conti,j1,j2
4862       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
4863       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
4864       j=i+2
4865 c      write (iout,*) "eturn3",i,j,j1,j2
4866       a_temp(1,1)=a22
4867       a_temp(1,2)=a23
4868       a_temp(2,1)=a32
4869       a_temp(2,2)=a33
4870 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4871 C
4872 C               Third-order contributions
4873 C
4874 C                 (i+2)o----(i+3)
4875 C                      | |
4876 C                      | |
4877 C                 (i+1)o----i
4878 C
4879 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4880 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4881         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4882 c auxalary matices for theta gradient
4883 c auxalary matrix for i+1 and constant i+2
4884         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4885 c auxalary matrix for i+2 and constant i+1
4886         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4887         call transpose2(auxmat(1,1),auxmat1(1,1))
4888         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4889         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4890         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4891         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4892         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4893         if (shield_mode.eq.0) then
4894         fac_shield(i)=1.0
4895         fac_shield(j)=1.0
4896 C        else
4897 C        fac_shield(i)=0.4
4898 C        fac_shield(j)=0.6
4899         endif
4900         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4901      &  *fac_shield(i)*fac_shield(j)*faclipij
4902         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4903      &  *fac_shield(i)*fac_shield(j)
4904         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4905      &    eello_t3
4906 C#ifdef NEWCORR
4907 C Derivatives in theta
4908         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4909      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4910      &   *fac_shield(i)*fac_shield(j)*faclipij
4911         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4912      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4913      &   *fac_shield(i)*fac_shield(j)*faclipij
4914 C#endif
4915
4916 C Derivatives in shield mode
4917           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4918      &  (shield_mode.gt.0)) then
4919 C          print *,i,j
4920
4921           do ilist=1,ishield_list(i)
4922            iresshield=shield_list(ilist,i)
4923            do k=1,3
4924            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4925 C     &      *2.0
4926            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4927      &              rlocshield
4928      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4929             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4930      &      +rlocshield
4931            enddo
4932           enddo
4933           do ilist=1,ishield_list(j)
4934            iresshield=shield_list(ilist,j)
4935            do k=1,3
4936            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4937 C     &     *2.0
4938            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4939      &              rlocshield
4940      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4941            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4942      &             +rlocshield
4943
4944            enddo
4945           enddo
4946
4947           do k=1,3
4948             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4949      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4950             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4951      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4952             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4953      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4954             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4955      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4956            enddo
4957            endif
4958
4959 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4960 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4961 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4962 cd     &    ' eello_turn3_num',4*eello_turn3_num
4963 C Derivatives in gamma(i)
4964         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4965         call transpose2(auxmat2(1,1),auxmat3(1,1))
4966         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4967         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4968      &   *fac_shield(i)*fac_shield(j)*faclipij
4969 C Derivatives in gamma(i+1)
4970         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4971         call transpose2(auxmat2(1,1),auxmat3(1,1))
4972         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4973         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4974      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4975      &   *fac_shield(i)*fac_shield(j)*faclipij
4976 C Cartesian derivatives
4977         do l=1,3
4978 c            ghalf1=0.5d0*agg(l,1)
4979 c            ghalf2=0.5d0*agg(l,2)
4980 c            ghalf3=0.5d0*agg(l,3)
4981 c            ghalf4=0.5d0*agg(l,4)
4982           a_temp(1,1)=aggi(l,1)!+ghalf1
4983           a_temp(1,2)=aggi(l,2)!+ghalf2
4984           a_temp(2,1)=aggi(l,3)!+ghalf3
4985           a_temp(2,2)=aggi(l,4)!+ghalf4
4986           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4987           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4988      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4989      &      *fac_shield(i)*fac_shield(j)*faclipij
4990
4991           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4992           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4993           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4994           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4995           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4996           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4997      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4998      &      *fac_shield(i)*fac_shield(j)*faclipij
4999           a_temp(1,1)=aggj(l,1)!+ghalf1
5000           a_temp(1,2)=aggj(l,2)!+ghalf2
5001           a_temp(2,1)=aggj(l,3)!+ghalf3
5002           a_temp(2,2)=aggj(l,4)!+ghalf4
5003           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5004           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5005      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5006      &      *fac_shield(i)*fac_shield(j)*faclipij
5007           a_temp(1,1)=aggj1(l,1)
5008           a_temp(1,2)=aggj1(l,2)
5009           a_temp(2,1)=aggj1(l,3)
5010           a_temp(2,2)=aggj1(l,4)
5011           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5012           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5013      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5014      &      *fac_shield(i)*fac_shield(j)*faclipij
5015         enddo
5016         gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5017      &    ssgradlipi*eello_t3/4.0d0*lipscale
5018         gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5019      &    ssgradlipj*eello_t3/4.0d0*lipscale
5020         gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5021      &    ssgradlipi*eello_t3/4.0d0*lipscale
5022         gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5023      &    ssgradlipj*eello_t3/4.0d0*lipscale
5024
5025       return
5026       end
5027 C-------------------------------------------------------------------------------
5028       subroutine eturn4(i,eello_turn4)
5029 C Third- and fourth-order contributions from turns
5030       implicit real*8 (a-h,o-z)
5031       include 'DIMENSIONS'
5032       include 'COMMON.IOUNITS'
5033       include 'COMMON.GEO'
5034       include 'COMMON.VAR'
5035       include 'COMMON.LOCAL'
5036       include 'COMMON.CHAIN'
5037       include 'COMMON.DERIV'
5038       include 'COMMON.INTERACT'
5039       include 'COMMON.CORRMAT'
5040       include 'COMMON.TORSION'
5041       include 'COMMON.VECTORS'
5042       include 'COMMON.FFIELD'
5043       include 'COMMON.CONTROL'
5044       include 'COMMON.SHIELD'
5045       dimension ggg(3)
5046       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5047      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5048      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5049      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5050      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5051      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5052      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5053       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5054      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5055       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5056      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5057      &    num_conti,j1,j2
5058       j=i+3
5059 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5060 C
5061 C               Fourth-order contributions
5062 C
5063 C                 (i+3)o----(i+4)
5064 C                     /  |
5065 C               (i+2)o   |
5066 C                     \  |
5067 C                 (i+1)o----i
5068 C
5069 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5070 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5071 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5072 c        write(iout,*)"WCHODZE W PROGRAM"
5073         a_temp(1,1)=a22
5074         a_temp(1,2)=a23
5075         a_temp(2,1)=a32
5076         a_temp(2,2)=a33
5077         iti1=itype2loc(itype(i+1))
5078         iti2=itype2loc(itype(i+2))
5079         iti3=itype2loc(itype(i+3))
5080 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5081         call transpose2(EUg(1,1,i+1),e1t(1,1))
5082         call transpose2(Eug(1,1,i+2),e2t(1,1))
5083         call transpose2(Eug(1,1,i+3),e3t(1,1))
5084 C Ematrix derivative in theta
5085         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5086         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5087         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5088         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5089 c       eta1 in derivative theta
5090         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5091         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5092 c       auxgvec is derivative of Ub2 so i+3 theta
5093         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5094 c       auxalary matrix of E i+1
5095         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5096 c        s1=0.0
5097 c        gs1=0.0
5098         s1=scalar2(b1(1,i+2),auxvec(1))
5099 c derivative of theta i+2 with constant i+3
5100         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5101 c derivative of theta i+2 with constant i+2
5102         gs32=scalar2(b1(1,i+2),auxgvec(1))
5103 c derivative of E matix in theta of i+1
5104         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5105
5106         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5107 c       ea31 in derivative theta
5108         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5109         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5110 c auxilary matrix auxgvec of Ub2 with constant E matirx
5111         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5112 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5113         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5114
5115 c        s2=0.0
5116 c        gs2=0.0
5117         s2=scalar2(b1(1,i+1),auxvec(1))
5118 c derivative of theta i+1 with constant i+3
5119         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5120 c derivative of theta i+2 with constant i+1
5121         gs21=scalar2(b1(1,i+1),auxgvec(1))
5122 c derivative of theta i+3 with constant i+1
5123         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5124 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5125 c     &  gtb1(1,i+1)
5126         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5127 c two derivatives over diffetent matrices
5128 c gtae3e2 is derivative over i+3
5129         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5130 c ae3gte2 is derivative over i+2
5131         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5132         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5133 c three possible derivative over theta E matices
5134 c i+1
5135         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5136 c i+2
5137         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5138 c i+3
5139         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5140         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5141
5142         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5143         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5144         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5145         if (shield_mode.eq.0) then
5146         fac_shield(i)=1.0
5147         fac_shield(j)=1.0
5148 C        else
5149 C        fac_shield(i)=0.6
5150 C        fac_shield(j)=0.4
5151         endif
5152         eello_turn4=eello_turn4-(s1+s2+s3)
5153      &  *fac_shield(i)*fac_shield(j)*faclipij
5154         eello_t4=-(s1+s2+s3)
5155      &  *fac_shield(i)*fac_shield(j)
5156 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5157         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5158      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5159 C Now derivative over shield:
5160           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5161      &  (shield_mode.gt.0)) then
5162 C          print *,i,j
5163
5164           do ilist=1,ishield_list(i)
5165            iresshield=shield_list(ilist,i)
5166            do k=1,3
5167            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5168 C     &      *2.0
5169            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5170      &              rlocshield
5171      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5172             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5173      &      +rlocshield
5174            enddo
5175           enddo
5176           do ilist=1,ishield_list(j)
5177            iresshield=shield_list(ilist,j)
5178            do k=1,3
5179            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5180 C     &     *2.0
5181            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5182      &              rlocshield
5183      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5184            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5185      &             +rlocshield
5186
5187            enddo
5188           enddo
5189
5190           do k=1,3
5191             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5192      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5193             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5194      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5195             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5196      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5197             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5198      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5199            enddo
5200            endif
5201 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5202 cd     &    ' eello_turn4_num',8*eello_turn4_num
5203 #ifdef NEWCORR
5204         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5205      &                  -(gs13+gsE13+gsEE1)*wturn4
5206      &  *fac_shield(i)*fac_shield(j)
5207         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5208      &                    -(gs23+gs21+gsEE2)*wturn4
5209      &  *fac_shield(i)*fac_shield(j)
5210
5211         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5212      &                    -(gs32+gsE31+gsEE3)*wturn4
5213      &  *fac_shield(i)*fac_shield(j)
5214
5215 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5216 c     &   gs2
5217 #endif
5218         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5219      &      'eturn4',i,j,-(s1+s2+s3)
5220 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5221 c     &    ' eello_turn4_num',8*eello_turn4_num
5222 C Derivatives in gamma(i)
5223         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5224         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5225         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5226         s1=scalar2(b1(1,i+2),auxvec(1))
5227         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5228         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5229         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5230      &  *fac_shield(i)*fac_shield(j)*faclipij
5231 C Derivatives in gamma(i+1)
5232         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5233         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5234         s2=scalar2(b1(1,i+1),auxvec(1))
5235         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5236         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5237         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5238         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5239      &  *fac_shield(i)*fac_shield(j)*faclipij
5240 C Derivatives in gamma(i+2)
5241         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5242         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5243         s1=scalar2(b1(1,i+2),auxvec(1))
5244         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5245         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5246         s2=scalar2(b1(1,i+1),auxvec(1))
5247         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5248         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5249         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5250         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5251      &  *fac_shield(i)*fac_shield(j)*faclipij
5252 C Cartesian derivatives
5253 C Derivatives of this turn contributions in DC(i+2)
5254         if (j.lt.nres-1) then
5255           do l=1,3
5256             a_temp(1,1)=agg(l,1)
5257             a_temp(1,2)=agg(l,2)
5258             a_temp(2,1)=agg(l,3)
5259             a_temp(2,2)=agg(l,4)
5260             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5261             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5262             s1=scalar2(b1(1,i+2),auxvec(1))
5263             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5264             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5265             s2=scalar2(b1(1,i+1),auxvec(1))
5266             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5267             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5268             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5269             ggg(l)=-(s1+s2+s3)
5270             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5271      &       *fac_shield(i)*fac_shield(j)*faclipij
5272           enddo
5273         endif
5274 C Remaining derivatives of this turn contribution
5275         do l=1,3
5276           a_temp(1,1)=aggi(l,1)
5277           a_temp(1,2)=aggi(l,2)
5278           a_temp(2,1)=aggi(l,3)
5279           a_temp(2,2)=aggi(l,4)
5280           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5281           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5282           s1=scalar2(b1(1,i+2),auxvec(1))
5283           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5284           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5285           s2=scalar2(b1(1,i+1),auxvec(1))
5286           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5287           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5288           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5289           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5290      &     *fac_shield(i)*fac_shield(j)*faclipij
5291           a_temp(1,1)=aggi1(l,1)
5292           a_temp(1,2)=aggi1(l,2)
5293           a_temp(2,1)=aggi1(l,3)
5294           a_temp(2,2)=aggi1(l,4)
5295           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5296           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5297           s1=scalar2(b1(1,i+2),auxvec(1))
5298           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5299           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5300           s2=scalar2(b1(1,i+1),auxvec(1))
5301           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5302           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5303           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5304           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5305      &      *fac_shield(i)*fac_shield(j)*faclipij
5306           a_temp(1,1)=aggj(l,1)
5307           a_temp(1,2)=aggj(l,2)
5308           a_temp(2,1)=aggj(l,3)
5309           a_temp(2,2)=aggj(l,4)
5310           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5311           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5312           s1=scalar2(b1(1,i+2),auxvec(1))
5313           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5314           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5315           s2=scalar2(b1(1,i+1),auxvec(1))
5316           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5317           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5318           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5319           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5320      &      *fac_shield(i)*fac_shield(j)*faclipij
5321           a_temp(1,1)=aggj1(l,1)
5322           a_temp(1,2)=aggj1(l,2)
5323           a_temp(2,1)=aggj1(l,3)
5324           a_temp(2,2)=aggj1(l,4)
5325           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5326           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5327           s1=scalar2(b1(1,i+2),auxvec(1))
5328           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5329           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5330           s2=scalar2(b1(1,i+1),auxvec(1))
5331           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5332           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5333           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5334 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5335           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5336      &      *fac_shield(i)*fac_shield(j)*faclipij
5337         enddo
5338         gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5339      &    ssgradlipi*eello_t4/4.0d0*lipscale
5340         gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5341      &    ssgradlipj*eello_t4/4.0d0*lipscale
5342         gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5343      &    ssgradlipi*eello_t4/4.0d0*lipscale
5344         gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5345      &    ssgradlipj*eello_t4/4.0d0*lipscale
5346       return
5347       end
5348 C-----------------------------------------------------------------------------
5349       subroutine vecpr(u,v,w)
5350       implicit real*8(a-h,o-z)
5351       dimension u(3),v(3),w(3)
5352       w(1)=u(2)*v(3)-u(3)*v(2)
5353       w(2)=-u(1)*v(3)+u(3)*v(1)
5354       w(3)=u(1)*v(2)-u(2)*v(1)
5355       return
5356       end
5357 C-----------------------------------------------------------------------------
5358       subroutine unormderiv(u,ugrad,unorm,ungrad)
5359 C This subroutine computes the derivatives of a normalized vector u, given
5360 C the derivatives computed without normalization conditions, ugrad. Returns
5361 C ungrad.
5362       implicit none
5363       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5364       double precision vec(3)
5365       double precision scalar
5366       integer i,j
5367 c      write (2,*) 'ugrad',ugrad
5368 c      write (2,*) 'u',u
5369       do i=1,3
5370         vec(i)=scalar(ugrad(1,i),u(1))
5371       enddo
5372 c      write (2,*) 'vec',vec
5373       do i=1,3
5374         do j=1,3
5375           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5376         enddo
5377       enddo
5378 c      write (2,*) 'ungrad',ungrad
5379       return
5380       end
5381 C-----------------------------------------------------------------------------
5382       subroutine escp_soft_sphere(evdw2,evdw2_14)
5383 C
5384 C This subroutine calculates the excluded-volume interaction energy between
5385 C peptide-group centers and side chains and its gradient in virtual-bond and
5386 C side-chain vectors.
5387 C
5388       implicit real*8 (a-h,o-z)
5389       include 'DIMENSIONS'
5390       include 'COMMON.GEO'
5391       include 'COMMON.VAR'
5392       include 'COMMON.LOCAL'
5393       include 'COMMON.CHAIN'
5394       include 'COMMON.DERIV'
5395       include 'COMMON.INTERACT'
5396       include 'COMMON.FFIELD'
5397       include 'COMMON.IOUNITS'
5398       include 'COMMON.CONTROL'
5399       dimension ggg(3)
5400       double precision boxshift
5401       evdw2=0.0D0
5402       evdw2_14=0.0d0
5403       r0_scp=4.5d0
5404 cd    print '(a)','Enter ESCP'
5405 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5406 C      do xshift=-1,1
5407 C      do yshift=-1,1
5408 C      do zshift=-1,1
5409 c      do i=iatscp_s,iatscp_e
5410       do ikont=g_listscp_start,g_listscp_end
5411         i=newcontlistscpi(ikont)
5412         j=newcontlistscpj(ikont)
5413         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5414         iteli=itel(i)
5415         xi=0.5D0*(c(1,i)+c(1,i+1))
5416         yi=0.5D0*(c(2,i)+c(2,i+1))
5417         zi=0.5D0*(c(3,i)+c(3,i+1))
5418 C Return atom into box, boxxsize is size of box in x dimension
5419 c  134   continue
5420 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5421 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5422 C Condition for being inside the proper box
5423 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5424 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5425 c        go to 134
5426 c        endif
5427 c  135   continue
5428 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5429 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5430 C Condition for being inside the proper box
5431 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5432 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5433 c        go to 135
5434 c c       endif
5435 c  136   continue
5436 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5437 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5438 cC Condition for being inside the proper box
5439 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5440 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5441 c        go to 136
5442 c        endif
5443           call to_box(xi,yi,zi)
5444 C          xi=xi+xshift*boxxsize
5445 C          yi=yi+yshift*boxysize
5446 C          zi=zi+zshift*boxzsize
5447 c        do iint=1,nscp_gr(i)
5448
5449 c        do j=iscpstart(i,iint),iscpend(i,iint)
5450           if (itype(j).eq.ntyp1) cycle
5451           itypj=iabs(itype(j))
5452 C Uncomment following three lines for SC-p interactions
5453 c         xj=c(1,nres+j)-xi
5454 c         yj=c(2,nres+j)-yi
5455 c         zj=c(3,nres+j)-zi
5456 C Uncomment following three lines for Ca-p interactions
5457           xj=c(1,j)
5458           yj=c(2,j)
5459           zj=c(3,j)
5460           call to_box(xj,yj,zj)
5461           xj=boxshift(xj-xi,boxxsize)
5462           yj=boxshift(yj-yi,boxysize)
5463           zj=boxshift(zj-zi,boxzsize)
5464 C          xj=xj-xi
5465 C          yj=yj-yi
5466 C          zj=zj-zi
5467           rij=xj*xj+yj*yj+zj*zj
5468
5469           r0ij=r0_scp
5470           r0ijsq=r0ij*r0ij
5471           if (rij.lt.r0ijsq) then
5472             evdwij=0.25d0*(rij-r0ijsq)**2
5473             fac=rij-r0ijsq
5474           else
5475             evdwij=0.0d0
5476             fac=0.0d0
5477           endif
5478           evdw2=evdw2+evdwij
5479 C
5480 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5481 C
5482           ggg(1)=xj*fac
5483           ggg(2)=yj*fac
5484           ggg(3)=zj*fac
5485           do k=1,3
5486             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5487             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5488           enddo
5489 c        enddo
5490
5491 c        enddo ! iint
5492       enddo ! i
5493 C      enddo !zshift
5494 C      enddo !yshift
5495 C      enddo !xshift
5496       return
5497       end
5498 C-----------------------------------------------------------------------------
5499       subroutine escp(evdw2,evdw2_14)
5500 C
5501 C This subroutine calculates the excluded-volume interaction energy between
5502 C peptide-group centers and side chains and its gradient in virtual-bond and
5503 C side-chain vectors.
5504 C
5505       implicit none
5506       include 'DIMENSIONS'
5507       include 'COMMON.GEO'
5508       include 'COMMON.VAR'
5509       include 'COMMON.LOCAL'
5510       include 'COMMON.CHAIN'
5511       include 'COMMON.DERIV'
5512       include 'COMMON.INTERACT'
5513       include 'COMMON.FFIELD'
5514       include 'COMMON.IOUNITS'
5515       include 'COMMON.CONTROL'
5516       include 'COMMON.SPLITELE'
5517       double precision ggg(3)
5518       integer i,iint,j,k,iteli,itypj,subchap,ikont
5519       double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5520      & fac,e1,e2,rij
5521       double precision evdw2,evdw2_14,evdwij
5522       double precision sscale,sscagrad
5523       double precision boxshift
5524       evdw2=0.0D0
5525       evdw2_14=0.0d0
5526 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5527 cd    print '(a)','Enter ESCP'
5528 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5529 C      do xshift=-1,1
5530 C      do yshift=-1,1
5531 C      do zshift=-1,1
5532       if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5533 c      do i=iatscp_s,iatscp_e
5534       do ikont=g_listscp_start,g_listscp_end
5535         i=newcontlistscpi(ikont)
5536         j=newcontlistscpj(ikont)
5537         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5538         iteli=itel(i)
5539         xi=0.5D0*(c(1,i)+c(1,i+1))
5540         yi=0.5D0*(c(2,i)+c(2,i+1))
5541         zi=0.5D0*(c(3,i)+c(3,i+1))
5542         call to_box(xi,yi,zi)
5543 c        do iint=1,nscp_gr(i)
5544
5545 c        do j=iscpstart(i,iint),iscpend(i,iint)
5546           itypj=iabs(itype(j))
5547           if (itypj.eq.ntyp1) cycle
5548 C Uncomment following three lines for SC-p interactions
5549 c         xj=c(1,nres+j)-xi
5550 c         yj=c(2,nres+j)-yi
5551 c         zj=c(3,nres+j)-zi
5552 C Uncomment following three lines for Ca-p interactions
5553           xj=c(1,j)
5554           yj=c(2,j)
5555           zj=c(3,j)
5556           call to_box(xj,yj,zj)
5557           xj=boxshift(xj-xi,boxxsize)
5558           yj=boxshift(yj-yi,boxysize)
5559           zj=boxshift(zj-zi,boxzsize)
5560 c          print *,xj,yj,zj,'polozenie j'
5561           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5562 c          print *,rrij
5563           sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5564 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5565 c          if (sss.eq.0) print *,'czasem jest OK'
5566           if (sss.le.0.0d0) cycle
5567           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5568           fac=rrij**expon2
5569           e1=fac*fac*aad(itypj,iteli)
5570           e2=fac*bad(itypj,iteli)
5571           if (iabs(j-i) .le. 2) then
5572             e1=scal14*e1
5573             e2=scal14*e2
5574             evdw2_14=evdw2_14+(e1+e2)*sss
5575           endif
5576           evdwij=e1+e2
5577           evdw2=evdw2+evdwij*sss
5578           if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5579      &        'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5580      &       evdwij,iteli,itypj,fac,aad(itypj,iteli),
5581      &       bad(itypj,iteli)
5582 C
5583 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5584 C
5585           fac=-(evdwij+e1)*rrij*sss
5586           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5587           ggg(1)=xj*fac
5588           ggg(2)=yj*fac
5589           ggg(3)=zj*fac
5590 cgrad          if (j.lt.i) then
5591 cd          write (iout,*) 'j<i'
5592 C Uncomment following three lines for SC-p interactions
5593 c           do k=1,3
5594 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5595 c           enddo
5596 cgrad          else
5597 cd          write (iout,*) 'j>i'
5598 cgrad            do k=1,3
5599 cgrad              ggg(k)=-ggg(k)
5600 C Uncomment following line for SC-p interactions
5601 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5602 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5603 cgrad            enddo
5604 cgrad          endif
5605 cgrad          do k=1,3
5606 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5607 cgrad          enddo
5608 cgrad          kstart=min0(i+1,j)
5609 cgrad          kend=max0(i-1,j-1)
5610 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5611 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5612 cgrad          do k=kstart,kend
5613 cgrad            do l=1,3
5614 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5615 cgrad            enddo
5616 cgrad          enddo
5617           do k=1,3
5618             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5619             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5620           enddo
5621 c        endif !endif for sscale cutoff
5622 c        enddo ! j
5623
5624 c        enddo ! iint
5625       enddo ! i
5626 c      enddo !zshift
5627 c      enddo !yshift
5628 c      enddo !xshift
5629       do i=1,nct
5630         do j=1,3
5631           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5632           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5633           gradx_scp(j,i)=expon*gradx_scp(j,i)
5634         enddo
5635       enddo
5636 C******************************************************************************
5637 C
5638 C                              N O T E !!!
5639 C
5640 C To save time the factor EXPON has been extracted from ALL components
5641 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5642 C use!
5643 C
5644 C******************************************************************************
5645       return
5646       end
5647 C--------------------------------------------------------------------------
5648       subroutine edis(ehpb)
5649 C
5650 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5651 C
5652       implicit real*8 (a-h,o-z)
5653       include 'DIMENSIONS'
5654       include 'COMMON.SBRIDGE'
5655       include 'COMMON.CHAIN'
5656       include 'COMMON.DERIV'
5657       include 'COMMON.VAR'
5658       include 'COMMON.INTERACT'
5659       include 'COMMON.IOUNITS'
5660       include 'COMMON.CONTROL'
5661       dimension ggg(3),ggg_peak(3,1000)
5662       ehpb=0.0D0
5663       do i=1,3
5664        ggg(i)=0.0d0
5665       enddo
5666 c 8/21/18 AL: added explicit restraints on reference coords
5667 c      write (iout,*) "restr_on_coord",restr_on_coord
5668       if (restr_on_coord) then
5669
5670       do i=nnt,nct
5671         ecoor=0.0d0
5672         if (itype(i).eq.ntyp1) cycle
5673         do j=1,3
5674           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5675           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5676         enddo
5677         if (itype(i).ne.10) then
5678           do j=1,3
5679             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5680             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5681           enddo
5682         endif
5683         if (energy_dec) write (iout,*)
5684      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5685         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5686       enddo
5687
5688       endif
5689 C      write (iout,*) ,"link_end",link_end,constr_dist
5690 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5691 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5692 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5693 c     &  " link_end_peak",link_end_peak
5694       if (link_end.eq.0.and.link_end_peak.eq.0) return
5695       do i=link_start_peak,link_end_peak
5696         ehpb_peak=0.0d0
5697 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5698 c     &   ipeak(1,i),ipeak(2,i)
5699         do ip=ipeak(1,i),ipeak(2,i)
5700           ii=ihpb_peak(ip)
5701           jj=jhpb_peak(ip)
5702           dd=dist(ii,jj)
5703           iip=ip-ipeak(1,i)+1
5704 C iii and jjj point to the residues for which the distance is assigned.
5705 c          if (ii.gt.nres) then
5706 c            iii=ii-nres
5707 c            jjj=jj-nres
5708 c          else
5709 c            iii=ii
5710 c            jjj=jj
5711 c          endif
5712           if (ii.gt.nres) then
5713             iii=ii-nres
5714           else
5715             iii=ii
5716           endif
5717           if (jj.gt.nres) then
5718             jjj=jj-nres
5719           else
5720             jjj=jj
5721           endif
5722           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5723           aux=dexp(-scal_peak*aux)
5724           ehpb_peak=ehpb_peak+aux
5725           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5726      &      forcon_peak(ip))*aux/dd
5727           do j=1,3
5728             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5729           enddo
5730           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5731      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5732      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5733         enddo
5734 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5735         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5736         do ip=ipeak(1,i),ipeak(2,i)
5737           iip=ip-ipeak(1,i)+1
5738           do j=1,3
5739             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5740           enddo
5741           ii=ihpb_peak(ip)
5742           jj=jhpb_peak(ip)
5743 C iii and jjj point to the residues for which the distance is assigned.
5744 c          if (ii.gt.nres) then
5745 c            iii=ii-nres
5746 c            jjj=jj-nres
5747 c          else
5748 c            iii=ii
5749 c            jjj=jj
5750 c          endif
5751           if (ii.gt.nres) then
5752             iii=ii-nres
5753           else
5754             iii=ii
5755           endif
5756           if (jj.gt.nres) then
5757             jjj=jj-nres
5758           else
5759             jjj=jj
5760           endif
5761           if (iii.lt.ii) then
5762             do j=1,3
5763               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5764             enddo
5765           endif
5766           if (jjj.lt.jj) then
5767             do j=1,3
5768               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5769             enddo
5770           endif
5771           do k=1,3
5772             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5773             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5774           enddo
5775         enddo
5776       enddo
5777       do i=link_start,link_end
5778 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5779 C CA-CA distance used in regularization of structure.
5780         ii=ihpb(i)
5781         jj=jhpb(i)
5782 C iii and jjj point to the residues for which the distance is assigned.
5783         if (ii.gt.nres) then
5784           iii=ii-nres
5785         else
5786           iii=ii
5787         endif
5788         if (jj.gt.nres) then
5789           jjj=jj-nres
5790         else
5791           jjj=jj
5792         endif
5793 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5794 c     &    dhpb(i),dhpb1(i),forcon(i)
5795 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5796 C    distance and angle dependent SS bond potential.
5797 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5798 C     & iabs(itype(jjj)).eq.1) then
5799 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5800 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5801         if (.not.dyn_ss .and. i.le.nss) then
5802 C 15/02/13 CC dynamic SSbond - additional check
5803           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5804      &        iabs(itype(jjj)).eq.1) then
5805            call ssbond_ene(iii,jjj,eij)
5806            ehpb=ehpb+2*eij
5807          endif
5808 cd          write (iout,*) "eij",eij
5809 cd   &   ' waga=',waga,' fac=',fac
5810 !        else if (ii.gt.nres .and. jj.gt.nres) then
5811         else
5812 C Calculate the distance between the two points and its difference from the
5813 C target distance.
5814           dd=dist(ii,jj)
5815           if (irestr_type(i).eq.11) then
5816             ehpb=ehpb+fordepth(i)!**4.0d0
5817      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5818             fac=fordepth(i)!**4.0d0
5819      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5820             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5821      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5822      &        ehpb,irestr_type(i)
5823           else if (irestr_type(i).eq.10) then
5824 c AL 6//19/2018 cross-link restraints
5825             xdis = 0.5d0*(dd/forcon(i))**2
5826             expdis = dexp(-xdis)
5827 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5828             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5829 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5830 c     &          " wboltzd",wboltzd
5831             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5832 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5833             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5834      &           *expdis/(aux*forcon(i)**2)
5835             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5836      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5837      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5838           else if (irestr_type(i).eq.2) then
5839 c Quartic restraints
5840             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5841             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5842      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5843      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5844             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5845           else
5846 c Quadratic restraints
5847             rdis=dd-dhpb(i)
5848 C Get the force constant corresponding to this distance.
5849             waga=forcon(i)
5850 C Calculate the contribution to energy.
5851             ehpb=ehpb+0.5d0*waga*rdis*rdis
5852             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5853      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5854      &       0.5d0*waga*rdis*rdis,irestr_type(i)
5855 C
5856 C Evaluate gradient.
5857 C
5858             fac=waga*rdis/dd
5859           endif
5860 c Calculate Cartesian gradient
5861           do j=1,3
5862             ggg(j)=fac*(c(j,jj)-c(j,ii))
5863           enddo
5864 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5865 C If this is a SC-SC distance, we need to calculate the contributions to the
5866 C Cartesian gradient in the SC vectors (ghpbx).
5867           if (iii.lt.ii) then
5868             do j=1,3
5869               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5870             enddo
5871           endif
5872           if (jjj.lt.jj) then
5873             do j=1,3
5874               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5875             enddo
5876           endif
5877           do k=1,3
5878             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5879             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5880           enddo
5881         endif
5882       enddo
5883       return
5884       end
5885 C--------------------------------------------------------------------------
5886       subroutine ssbond_ene(i,j,eij)
5887 C
5888 C Calculate the distance and angle dependent SS-bond potential energy
5889 C using a free-energy function derived based on RHF/6-31G** ab initio
5890 C calculations of diethyl disulfide.
5891 C
5892 C A. Liwo and U. Kozlowska, 11/24/03
5893 C
5894       implicit real*8 (a-h,o-z)
5895       include 'DIMENSIONS'
5896       include 'COMMON.SBRIDGE'
5897       include 'COMMON.CHAIN'
5898       include 'COMMON.DERIV'
5899       include 'COMMON.LOCAL'
5900       include 'COMMON.INTERACT'
5901       include 'COMMON.VAR'
5902       include 'COMMON.IOUNITS'
5903       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5904       itypi=iabs(itype(i))
5905       xi=c(1,nres+i)
5906       yi=c(2,nres+i)
5907       zi=c(3,nres+i)
5908       dxi=dc_norm(1,nres+i)
5909       dyi=dc_norm(2,nres+i)
5910       dzi=dc_norm(3,nres+i)
5911 c      dsci_inv=dsc_inv(itypi)
5912       dsci_inv=vbld_inv(nres+i)
5913       itypj=iabs(itype(j))
5914 c      dscj_inv=dsc_inv(itypj)
5915       dscj_inv=vbld_inv(nres+j)
5916       xj=c(1,nres+j)-xi
5917       yj=c(2,nres+j)-yi
5918       zj=c(3,nres+j)-zi
5919       dxj=dc_norm(1,nres+j)
5920       dyj=dc_norm(2,nres+j)
5921       dzj=dc_norm(3,nres+j)
5922       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5923       rij=dsqrt(rrij)
5924       erij(1)=xj*rij
5925       erij(2)=yj*rij
5926       erij(3)=zj*rij
5927       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5928       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5929       om12=dxi*dxj+dyi*dyj+dzi*dzj
5930       do k=1,3
5931         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5932         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5933       enddo
5934       rij=1.0d0/rij
5935       deltad=rij-d0cm
5936       deltat1=1.0d0-om1
5937       deltat2=1.0d0+om2
5938       deltat12=om2-om1+2.0d0
5939       cosphi=om12-om1*om2
5940       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5941      &  +akct*deltad*deltat12
5942      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5943 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5944 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5945 c     &  " deltat12",deltat12," eij",eij
5946       ed=2*akcm*deltad+akct*deltat12
5947       pom1=akct*deltad
5948       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5949       eom1=-2*akth*deltat1-pom1-om2*pom2
5950       eom2= 2*akth*deltat2+pom1-om1*pom2
5951       eom12=pom2
5952       do k=1,3
5953         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5954         ghpbx(k,i)=ghpbx(k,i)-ggk
5955      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5956      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5957         ghpbx(k,j)=ghpbx(k,j)+ggk
5958      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5959      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5960         ghpbc(k,i)=ghpbc(k,i)-ggk
5961         ghpbc(k,j)=ghpbc(k,j)+ggk
5962       enddo
5963 C
5964 C Calculate the components of the gradient in DC and X
5965 C
5966 cgrad      do k=i,j-1
5967 cgrad        do l=1,3
5968 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5969 cgrad        enddo
5970 cgrad      enddo
5971       return
5972       end
5973 C--------------------------------------------------------------------------
5974       subroutine ebond(estr)
5975 c
5976 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5977 c
5978       implicit real*8 (a-h,o-z)
5979       include 'DIMENSIONS'
5980       include 'COMMON.LOCAL'
5981       include 'COMMON.GEO'
5982       include 'COMMON.INTERACT'
5983       include 'COMMON.DERIV'
5984       include 'COMMON.VAR'
5985       include 'COMMON.CHAIN'
5986       include 'COMMON.IOUNITS'
5987       include 'COMMON.NAMES'
5988       include 'COMMON.FFIELD'
5989       include 'COMMON.CONTROL'
5990       include 'COMMON.SETUP'
5991       double precision u(3),ud(3)
5992       estr=0.0d0
5993       estr1=0.0d0
5994       do i=ibondp_start,ibondp_end
5995 c  3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
5996 c      used
5997 #ifdef FIVEDIAG
5998         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5999         diff = vbld(i)-vbldp0
6000 #else
6001         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6002 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6003 c          do j=1,3
6004 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6005 c     &      *dc(j,i-1)/vbld(i)
6006 c          enddo
6007 c          if (energy_dec) write(iout,*)
6008 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6009 c        else
6010 C       Checking if it involves dummy (NH3+ or COO-) group
6011         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6012 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6013           diff = vbld(i)-vbldpDUM
6014           if (energy_dec) write(iout,*) "dum_bond",i,diff
6015         else
6016 C NO    vbldp0 is the equlibrium length of spring for peptide group
6017           diff = vbld(i)-vbldp0
6018         endif
6019 #endif
6020         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6021      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6022         estr=estr+diff*diff
6023         do j=1,3
6024           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6025         enddo
6026 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6027 c        endif
6028       enddo
6029
6030       estr=0.5d0*AKP*estr+estr1
6031 c
6032 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6033 c
6034       do i=ibond_start,ibond_end
6035         iti=iabs(itype(i))
6036         if (iti.ne.10 .and. iti.ne.ntyp1) then
6037           nbi=nbondterm(iti)
6038           if (nbi.eq.1) then
6039             diff=vbld(i+nres)-vbldsc0(1,iti)
6040             if (energy_dec)  write (iout,*)
6041      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6042      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6043             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6044             do j=1,3
6045               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6046             enddo
6047           else
6048             do j=1,nbi
6049               diff=vbld(i+nres)-vbldsc0(j,iti)
6050               ud(j)=aksc(j,iti)*diff
6051               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6052             enddo
6053             uprod=u(1)
6054             do j=2,nbi
6055               uprod=uprod*u(j)
6056             enddo
6057             usum=0.0d0
6058             usumsqder=0.0d0
6059             do j=1,nbi
6060               uprod1=1.0d0
6061               uprod2=1.0d0
6062               do k=1,nbi
6063                 if (k.ne.j) then
6064                   uprod1=uprod1*u(k)
6065                   uprod2=uprod2*u(k)*u(k)
6066                 endif
6067               enddo
6068               usum=usum+uprod1
6069               usumsqder=usumsqder+ud(j)*uprod2
6070             enddo
6071             estr=estr+uprod/usum
6072             do j=1,3
6073              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6074             enddo
6075           endif
6076         endif
6077       enddo
6078       return
6079       end
6080 #ifdef CRYST_THETA
6081 C--------------------------------------------------------------------------
6082       subroutine ebend(etheta)
6083 C
6084 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6085 C angles gamma and its derivatives in consecutive thetas and gammas.
6086 C
6087       implicit real*8 (a-h,o-z)
6088       include 'DIMENSIONS'
6089       include 'COMMON.LOCAL'
6090       include 'COMMON.GEO'
6091       include 'COMMON.INTERACT'
6092       include 'COMMON.DERIV'
6093       include 'COMMON.VAR'
6094       include 'COMMON.CHAIN'
6095       include 'COMMON.IOUNITS'
6096       include 'COMMON.NAMES'
6097       include 'COMMON.FFIELD'
6098       include 'COMMON.CONTROL'
6099       include 'COMMON.TORCNSTR'
6100       common /calcthet/ term1,term2,termm,diffak,ratak,
6101      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6102      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6103       double precision y(2),z(2)
6104       delta=0.02d0*pi
6105 c      time11=dexp(-2*time)
6106 c      time12=1.0d0
6107       etheta=0.0D0
6108 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6109       do i=ithet_start,ithet_end
6110         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6111      &  .or.itype(i).eq.ntyp1) cycle
6112 C Zero the energy function and its derivative at 0 or pi.
6113         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6114         it=itype(i-1)
6115         ichir1=isign(1,itype(i-2))
6116         ichir2=isign(1,itype(i))
6117          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6118          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6119          if (itype(i-1).eq.10) then
6120           itype1=isign(10,itype(i-2))
6121           ichir11=isign(1,itype(i-2))
6122           ichir12=isign(1,itype(i-2))
6123           itype2=isign(10,itype(i))
6124           ichir21=isign(1,itype(i))
6125           ichir22=isign(1,itype(i))
6126          endif
6127
6128         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6129 #ifdef OSF
6130           phii=phi(i)
6131           if (phii.ne.phii) phii=150.0
6132 #else
6133           phii=phi(i)
6134 #endif
6135           y(1)=dcos(phii)
6136           y(2)=dsin(phii)
6137         else
6138           y(1)=0.0D0
6139           y(2)=0.0D0
6140         endif
6141         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6142 #ifdef OSF
6143           phii1=phi(i+1)
6144           if (phii1.ne.phii1) phii1=150.0
6145           phii1=pinorm(phii1)
6146           z(1)=cos(phii1)
6147 #else
6148           phii1=phi(i+1)
6149 #endif
6150           z(1)=dcos(phii1)
6151           z(2)=dsin(phii1)
6152         else
6153           z(1)=0.0D0
6154           z(2)=0.0D0
6155         endif
6156 C Calculate the "mean" value of theta from the part of the distribution
6157 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6158 C In following comments this theta will be referred to as t_c.
6159         thet_pred_mean=0.0d0
6160         do k=1,2
6161             athetk=athet(k,it,ichir1,ichir2)
6162             bthetk=bthet(k,it,ichir1,ichir2)
6163           if (it.eq.10) then
6164              athetk=athet(k,itype1,ichir11,ichir12)
6165              bthetk=bthet(k,itype2,ichir21,ichir22)
6166           endif
6167          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6168 c         write(iout,*) 'chuj tu', y(k),z(k)
6169         enddo
6170         dthett=thet_pred_mean*ssd
6171         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6172 C Derivatives of the "mean" values in gamma1 and gamma2.
6173         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6174      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6175          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6176      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6177          if (it.eq.10) then
6178       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6179      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6180         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6181      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6182          endif
6183         if (theta(i).gt.pi-delta) then
6184           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6185      &         E_tc0)
6186           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6187           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6188           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6189      &        E_theta)
6190           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6191      &        E_tc)
6192         else if (theta(i).lt.delta) then
6193           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6194           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6195           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6196      &        E_theta)
6197           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6198           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6199      &        E_tc)
6200         else
6201           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6202      &        E_theta,E_tc)
6203         endif
6204         etheta=etheta+ethetai
6205         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6206      &      'ebend',i,ethetai,theta(i),itype(i)
6207         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6208         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6209         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6210       enddo
6211
6212 C Ufff.... We've done all this!!!
6213       return
6214       end
6215 C---------------------------------------------------------------------------
6216       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6217      &     E_tc)
6218       implicit real*8 (a-h,o-z)
6219       include 'DIMENSIONS'
6220       include 'COMMON.LOCAL'
6221       include 'COMMON.IOUNITS'
6222       common /calcthet/ term1,term2,termm,diffak,ratak,
6223      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6224      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6225 C Calculate the contributions to both Gaussian lobes.
6226 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6227 C The "polynomial part" of the "standard deviation" of this part of
6228 C the distributioni.
6229 ccc        write (iout,*) thetai,thet_pred_mean
6230         sig=polthet(3,it)
6231         do j=2,0,-1
6232           sig=sig*thet_pred_mean+polthet(j,it)
6233         enddo
6234 C Derivative of the "interior part" of the "standard deviation of the"
6235 C gamma-dependent Gaussian lobe in t_c.
6236         sigtc=3*polthet(3,it)
6237         do j=2,1,-1
6238           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6239         enddo
6240         sigtc=sig*sigtc
6241 C Set the parameters of both Gaussian lobes of the distribution.
6242 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6243         fac=sig*sig+sigc0(it)
6244         sigcsq=fac+fac
6245         sigc=1.0D0/sigcsq
6246 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6247         sigsqtc=-4.0D0*sigcsq*sigtc
6248 c       print *,i,sig,sigtc,sigsqtc
6249 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6250         sigtc=-sigtc/(fac*fac)
6251 C Following variable is sigma(t_c)**(-2)
6252         sigcsq=sigcsq*sigcsq
6253         sig0i=sig0(it)
6254         sig0inv=1.0D0/sig0i**2
6255         delthec=thetai-thet_pred_mean
6256         delthe0=thetai-theta0i
6257         term1=-0.5D0*sigcsq*delthec*delthec
6258         term2=-0.5D0*sig0inv*delthe0*delthe0
6259 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6260 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6261 C NaNs in taking the logarithm. We extract the largest exponent which is added
6262 C to the energy (this being the log of the distribution) at the end of energy
6263 C term evaluation for this virtual-bond angle.
6264         if (term1.gt.term2) then
6265           termm=term1
6266           term2=dexp(term2-termm)
6267           term1=1.0d0
6268         else
6269           termm=term2
6270           term1=dexp(term1-termm)
6271           term2=1.0d0
6272         endif
6273 C The ratio between the gamma-independent and gamma-dependent lobes of
6274 C the distribution is a Gaussian function of thet_pred_mean too.
6275         diffak=gthet(2,it)-thet_pred_mean
6276         ratak=diffak/gthet(3,it)**2
6277         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6278 C Let's differentiate it in thet_pred_mean NOW.
6279         aktc=ak*ratak
6280 C Now put together the distribution terms to make complete distribution.
6281         termexp=term1+ak*term2
6282         termpre=sigc+ak*sig0i
6283 C Contribution of the bending energy from this theta is just the -log of
6284 C the sum of the contributions from the two lobes and the pre-exponential
6285 C factor. Simple enough, isn't it?
6286         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6287 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6288 C NOW the derivatives!!!
6289 C 6/6/97 Take into account the deformation.
6290         E_theta=(delthec*sigcsq*term1
6291      &       +ak*delthe0*sig0inv*term2)/termexp
6292         E_tc=((sigtc+aktc*sig0i)/termpre
6293      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6294      &       aktc*term2)/termexp)
6295       return
6296       end
6297 c-----------------------------------------------------------------------------
6298       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6299       implicit real*8 (a-h,o-z)
6300       include 'DIMENSIONS'
6301       include 'COMMON.LOCAL'
6302       include 'COMMON.IOUNITS'
6303       common /calcthet/ term1,term2,termm,diffak,ratak,
6304      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6305      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6306       delthec=thetai-thet_pred_mean
6307       delthe0=thetai-theta0i
6308 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6309       t3 = thetai-thet_pred_mean
6310       t6 = t3**2
6311       t9 = term1
6312       t12 = t3*sigcsq
6313       t14 = t12+t6*sigsqtc
6314       t16 = 1.0d0
6315       t21 = thetai-theta0i
6316       t23 = t21**2
6317       t26 = term2
6318       t27 = t21*t26
6319       t32 = termexp
6320       t40 = t32**2
6321       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6322      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6323      & *(-t12*t9-ak*sig0inv*t27)
6324       return
6325       end
6326 #else
6327 C--------------------------------------------------------------------------
6328       subroutine ebend(etheta)
6329 C
6330 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6331 C angles gamma and its derivatives in consecutive thetas and gammas.
6332 C ab initio-derived potentials from
6333 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6334 C
6335       implicit real*8 (a-h,o-z)
6336       include 'DIMENSIONS'
6337       include 'COMMON.LOCAL'
6338       include 'COMMON.GEO'
6339       include 'COMMON.INTERACT'
6340       include 'COMMON.DERIV'
6341       include 'COMMON.VAR'
6342       include 'COMMON.CHAIN'
6343       include 'COMMON.IOUNITS'
6344       include 'COMMON.NAMES'
6345       include 'COMMON.FFIELD'
6346       include 'COMMON.CONTROL'
6347       include 'COMMON.TORCNSTR'
6348       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6349      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6350      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6351      & sinph1ph2(maxdouble,maxdouble)
6352       logical lprn /.false./, lprn1 /.false./
6353       etheta=0.0D0
6354       do i=ithet_start,ithet_end
6355 c        print *,i,itype(i-1),itype(i),itype(i-2)
6356         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6357      &  .or.itype(i).eq.ntyp1) cycle
6358 C        print *,i,theta(i)
6359         if (iabs(itype(i+1)).eq.20) iblock=2
6360         if (iabs(itype(i+1)).ne.20) iblock=1
6361         dethetai=0.0d0
6362         dephii=0.0d0
6363         dephii1=0.0d0
6364         theti2=0.5d0*theta(i)
6365         ityp2=ithetyp((itype(i-1)))
6366         do k=1,nntheterm
6367           coskt(k)=dcos(k*theti2)
6368           sinkt(k)=dsin(k*theti2)
6369         enddo
6370 C        print *,ethetai
6371         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6372 #ifdef OSF
6373           phii=phi(i)
6374           if (phii.ne.phii) phii=150.0
6375 #else
6376           phii=phi(i)
6377 #endif
6378           ityp1=ithetyp((itype(i-2)))
6379 C propagation of chirality for glycine type
6380           do k=1,nsingle
6381             cosph1(k)=dcos(k*phii)
6382             sinph1(k)=dsin(k*phii)
6383           enddo
6384         else
6385           phii=0.0d0
6386           do k=1,nsingle
6387           ityp1=ithetyp((itype(i-2)))
6388             cosph1(k)=0.0d0
6389             sinph1(k)=0.0d0
6390           enddo
6391         endif
6392         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6393 #ifdef OSF
6394           phii1=phi(i+1)
6395           if (phii1.ne.phii1) phii1=150.0
6396           phii1=pinorm(phii1)
6397 #else
6398           phii1=phi(i+1)
6399 #endif
6400           ityp3=ithetyp((itype(i)))
6401           do k=1,nsingle
6402             cosph2(k)=dcos(k*phii1)
6403             sinph2(k)=dsin(k*phii1)
6404           enddo
6405         else
6406           phii1=0.0d0
6407           ityp3=ithetyp((itype(i)))
6408           do k=1,nsingle
6409             cosph2(k)=0.0d0
6410             sinph2(k)=0.0d0
6411           enddo
6412         endif
6413         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6414         do k=1,ndouble
6415           do l=1,k-1
6416             ccl=cosph1(l)*cosph2(k-l)
6417             ssl=sinph1(l)*sinph2(k-l)
6418             scl=sinph1(l)*cosph2(k-l)
6419             csl=cosph1(l)*sinph2(k-l)
6420             cosph1ph2(l,k)=ccl-ssl
6421             cosph1ph2(k,l)=ccl+ssl
6422             sinph1ph2(l,k)=scl+csl
6423             sinph1ph2(k,l)=scl-csl
6424           enddo
6425         enddo
6426         if (lprn) then
6427         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6428      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6429         write (iout,*) "coskt and sinkt"
6430         do k=1,nntheterm
6431           write (iout,*) k,coskt(k),sinkt(k)
6432         enddo
6433         endif
6434         do k=1,ntheterm
6435           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6436           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6437      &      *coskt(k)
6438           if (lprn)
6439      &    write (iout,*) "k",k,"
6440      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6441      &     " ethetai",ethetai
6442         enddo
6443         if (lprn) then
6444         write (iout,*) "cosph and sinph"
6445         do k=1,nsingle
6446           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6447         enddo
6448         write (iout,*) "cosph1ph2 and sinph2ph2"
6449         do k=2,ndouble
6450           do l=1,k-1
6451             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6452      &         sinph1ph2(l,k),sinph1ph2(k,l)
6453           enddo
6454         enddo
6455         write(iout,*) "ethetai",ethetai
6456         endif
6457 C       print *,ethetai
6458         do m=1,ntheterm2
6459           do k=1,nsingle
6460             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6461      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6462      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6463      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6464             ethetai=ethetai+sinkt(m)*aux
6465             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6466             dephii=dephii+k*sinkt(m)*(
6467      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6468      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6469             dephii1=dephii1+k*sinkt(m)*(
6470      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6471      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6472             if (lprn)
6473      &      write (iout,*) "m",m," k",k," bbthet",
6474      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6475      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6476      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6477      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6478 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6479           enddo
6480         enddo
6481 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6482 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6483 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6484 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6485         if (lprn)
6486      &  write(iout,*) "ethetai",ethetai
6487 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6488         do m=1,ntheterm3
6489           do k=2,ndouble
6490             do l=1,k-1
6491               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6492      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6493      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6494      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6495               ethetai=ethetai+sinkt(m)*aux
6496               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6497               dephii=dephii+l*sinkt(m)*(
6498      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6499      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6500      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6501      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6502               dephii1=dephii1+(k-l)*sinkt(m)*(
6503      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6504      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6505      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6506      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6507               if (lprn) then
6508               write (iout,*) "m",m," k",k," l",l," ffthet",
6509      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6510      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6511      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6512      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6513      &            " ethetai",ethetai
6514               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6515      &            cosph1ph2(k,l)*sinkt(m),
6516      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6517               endif
6518             enddo
6519           enddo
6520         enddo
6521 10      continue
6522 c        lprn1=.true.
6523 C        print *,ethetai
6524         if (lprn1)
6525      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6526      &   i,theta(i)*rad2deg,phii*rad2deg,
6527      &   phii1*rad2deg,ethetai
6528 c        lprn1=.false.
6529         etheta=etheta+ethetai
6530         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6531         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6532         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6533       enddo
6534
6535       return
6536       end
6537 #endif
6538 #ifdef CRYST_SC
6539 c-----------------------------------------------------------------------------
6540       subroutine esc(escloc)
6541 C Calculate the local energy of a side chain and its derivatives in the
6542 C corresponding virtual-bond valence angles THETA and the spherical angles
6543 C ALPHA and OMEGA.
6544       implicit real*8 (a-h,o-z)
6545       include 'DIMENSIONS'
6546       include 'COMMON.GEO'
6547       include 'COMMON.LOCAL'
6548       include 'COMMON.VAR'
6549       include 'COMMON.INTERACT'
6550       include 'COMMON.DERIV'
6551       include 'COMMON.CHAIN'
6552       include 'COMMON.IOUNITS'
6553       include 'COMMON.NAMES'
6554       include 'COMMON.FFIELD'
6555       include 'COMMON.CONTROL'
6556       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6557      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6558       common /sccalc/ time11,time12,time112,theti,it,nlobit
6559       delta=0.02d0*pi
6560       escloc=0.0D0
6561 c     write (iout,'(a)') 'ESC'
6562       do i=loc_start,loc_end
6563         it=itype(i)
6564         if (it.eq.ntyp1) cycle
6565         if (it.eq.10) goto 1
6566         nlobit=nlob(iabs(it))
6567 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6568 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6569         theti=theta(i+1)-pipol
6570         x(1)=dtan(theti)
6571         x(2)=alph(i)
6572         x(3)=omeg(i)
6573
6574         if (x(2).gt.pi-delta) then
6575           xtemp(1)=x(1)
6576           xtemp(2)=pi-delta
6577           xtemp(3)=x(3)
6578           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6579           xtemp(2)=pi
6580           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6581           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6582      &        escloci,dersc(2))
6583           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6584      &        ddersc0(1),dersc(1))
6585           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6586      &        ddersc0(3),dersc(3))
6587           xtemp(2)=pi-delta
6588           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6589           xtemp(2)=pi
6590           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6591           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6592      &            dersc0(2),esclocbi,dersc02)
6593           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6594      &            dersc12,dersc01)
6595           call splinthet(x(2),0.5d0*delta,ss,ssd)
6596           dersc0(1)=dersc01
6597           dersc0(2)=dersc02
6598           dersc0(3)=0.0d0
6599           do k=1,3
6600             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6601           enddo
6602           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6603 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6604 c    &             esclocbi,ss,ssd
6605           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6606 c         escloci=esclocbi
6607 c         write (iout,*) escloci
6608         else if (x(2).lt.delta) then
6609           xtemp(1)=x(1)
6610           xtemp(2)=delta
6611           xtemp(3)=x(3)
6612           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6613           xtemp(2)=0.0d0
6614           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6615           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6616      &        escloci,dersc(2))
6617           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6618      &        ddersc0(1),dersc(1))
6619           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6620      &        ddersc0(3),dersc(3))
6621           xtemp(2)=delta
6622           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6623           xtemp(2)=0.0d0
6624           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6625           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6626      &            dersc0(2),esclocbi,dersc02)
6627           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6628      &            dersc12,dersc01)
6629           dersc0(1)=dersc01
6630           dersc0(2)=dersc02
6631           dersc0(3)=0.0d0
6632           call splinthet(x(2),0.5d0*delta,ss,ssd)
6633           do k=1,3
6634             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6635           enddo
6636           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6637 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6638 c    &             esclocbi,ss,ssd
6639           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6640 c         write (iout,*) escloci
6641         else
6642           call enesc(x,escloci,dersc,ddummy,.false.)
6643         endif
6644
6645         escloc=escloc+escloci
6646         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6647      &     'escloc',i,escloci
6648 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6649
6650         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6651      &   wscloc*dersc(1)
6652         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6653         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6654     1   continue
6655       enddo
6656       return
6657       end
6658 C---------------------------------------------------------------------------
6659       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6660       implicit real*8 (a-h,o-z)
6661       include 'DIMENSIONS'
6662       include 'COMMON.GEO'
6663       include 'COMMON.LOCAL'
6664       include 'COMMON.IOUNITS'
6665       common /sccalc/ time11,time12,time112,theti,it,nlobit
6666       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6667       double precision contr(maxlob,-1:1)
6668       logical mixed
6669 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6670         escloc_i=0.0D0
6671         do j=1,3
6672           dersc(j)=0.0D0
6673           if (mixed) ddersc(j)=0.0d0
6674         enddo
6675         x3=x(3)
6676
6677 C Because of periodicity of the dependence of the SC energy in omega we have
6678 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6679 C To avoid underflows, first compute & store the exponents.
6680
6681         do iii=-1,1
6682
6683           x(3)=x3+iii*dwapi
6684
6685           do j=1,nlobit
6686             do k=1,3
6687               z(k)=x(k)-censc(k,j,it)
6688             enddo
6689             do k=1,3
6690               Axk=0.0D0
6691               do l=1,3
6692                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6693               enddo
6694               Ax(k,j,iii)=Axk
6695             enddo
6696             expfac=0.0D0
6697             do k=1,3
6698               expfac=expfac+Ax(k,j,iii)*z(k)
6699             enddo
6700             contr(j,iii)=expfac
6701           enddo ! j
6702
6703         enddo ! iii
6704
6705         x(3)=x3
6706 C As in the case of ebend, we want to avoid underflows in exponentiation and
6707 C subsequent NaNs and INFs in energy calculation.
6708 C Find the largest exponent
6709         emin=contr(1,-1)
6710         do iii=-1,1
6711           do j=1,nlobit
6712             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6713           enddo
6714         enddo
6715         emin=0.5D0*emin
6716 cd      print *,'it=',it,' emin=',emin
6717
6718 C Compute the contribution to SC energy and derivatives
6719         do iii=-1,1
6720
6721           do j=1,nlobit
6722 #ifdef OSF
6723             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6724             if(adexp.ne.adexp) adexp=1.0
6725             expfac=dexp(adexp)
6726 #else
6727             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6728 #endif
6729 cd          print *,'j=',j,' expfac=',expfac
6730             escloc_i=escloc_i+expfac
6731             do k=1,3
6732               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6733             enddo
6734             if (mixed) then
6735               do k=1,3,2
6736                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6737      &            +gaussc(k,2,j,it))*expfac
6738               enddo
6739             endif
6740           enddo
6741
6742         enddo ! iii
6743
6744         dersc(1)=dersc(1)/cos(theti)**2
6745         ddersc(1)=ddersc(1)/cos(theti)**2
6746         ddersc(3)=ddersc(3)
6747
6748         escloci=-(dlog(escloc_i)-emin)
6749         do j=1,3
6750           dersc(j)=dersc(j)/escloc_i
6751         enddo
6752         if (mixed) then
6753           do j=1,3,2
6754             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6755           enddo
6756         endif
6757       return
6758       end
6759 C------------------------------------------------------------------------------
6760       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6761       implicit real*8 (a-h,o-z)
6762       include 'DIMENSIONS'
6763       include 'COMMON.GEO'
6764       include 'COMMON.LOCAL'
6765       include 'COMMON.IOUNITS'
6766       common /sccalc/ time11,time12,time112,theti,it,nlobit
6767       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6768       double precision contr(maxlob)
6769       logical mixed
6770
6771       escloc_i=0.0D0
6772
6773       do j=1,3
6774         dersc(j)=0.0D0
6775       enddo
6776
6777       do j=1,nlobit
6778         do k=1,2
6779           z(k)=x(k)-censc(k,j,it)
6780         enddo
6781         z(3)=dwapi
6782         do k=1,3
6783           Axk=0.0D0
6784           do l=1,3
6785             Axk=Axk+gaussc(l,k,j,it)*z(l)
6786           enddo
6787           Ax(k,j)=Axk
6788         enddo
6789         expfac=0.0D0
6790         do k=1,3
6791           expfac=expfac+Ax(k,j)*z(k)
6792         enddo
6793         contr(j)=expfac
6794       enddo ! j
6795
6796 C As in the case of ebend, we want to avoid underflows in exponentiation and
6797 C subsequent NaNs and INFs in energy calculation.
6798 C Find the largest exponent
6799       emin=contr(1)
6800       do j=1,nlobit
6801         if (emin.gt.contr(j)) emin=contr(j)
6802       enddo
6803       emin=0.5D0*emin
6804
6805 C Compute the contribution to SC energy and derivatives
6806
6807       dersc12=0.0d0
6808       do j=1,nlobit
6809         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6810         escloc_i=escloc_i+expfac
6811         do k=1,2
6812           dersc(k)=dersc(k)+Ax(k,j)*expfac
6813         enddo
6814         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6815      &            +gaussc(1,2,j,it))*expfac
6816         dersc(3)=0.0d0
6817       enddo
6818
6819       dersc(1)=dersc(1)/cos(theti)**2
6820       dersc12=dersc12/cos(theti)**2
6821       escloci=-(dlog(escloc_i)-emin)
6822       do j=1,2
6823         dersc(j)=dersc(j)/escloc_i
6824       enddo
6825       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6826       return
6827       end
6828 #else
6829 c----------------------------------------------------------------------------------
6830       subroutine esc(escloc)
6831 C Calculate the local energy of a side chain and its derivatives in the
6832 C corresponding virtual-bond valence angles THETA and the spherical angles
6833 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6834 C added by Urszula Kozlowska. 07/11/2007
6835 C
6836       implicit real*8 (a-h,o-z)
6837       include 'DIMENSIONS'
6838       include 'COMMON.GEO'
6839       include 'COMMON.LOCAL'
6840       include 'COMMON.VAR'
6841       include 'COMMON.SCROT'
6842       include 'COMMON.INTERACT'
6843       include 'COMMON.DERIV'
6844       include 'COMMON.CHAIN'
6845       include 'COMMON.IOUNITS'
6846       include 'COMMON.NAMES'
6847       include 'COMMON.FFIELD'
6848       include 'COMMON.CONTROL'
6849       include 'COMMON.VECTORS'
6850       double precision x_prime(3),y_prime(3),z_prime(3)
6851      &    , sumene,dsc_i,dp2_i,x(65),
6852      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6853      &    de_dxx,de_dyy,de_dzz,de_dt
6854       double precision s1_t,s1_6_t,s2_t,s2_6_t
6855       double precision
6856      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6857      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6858      & dt_dCi(3),dt_dCi1(3)
6859       common /sccalc/ time11,time12,time112,theti,it,nlobit
6860       delta=0.02d0*pi
6861       escloc=0.0D0
6862       do i=loc_start,loc_end
6863         if (itype(i).eq.ntyp1) cycle
6864         costtab(i+1) =dcos(theta(i+1))
6865         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6866         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6867         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6868         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6869         cosfac=dsqrt(cosfac2)
6870         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6871         sinfac=dsqrt(sinfac2)
6872         it=iabs(itype(i))
6873         if (it.eq.10) goto 1
6874 c
6875 C  Compute the axes of tghe local cartesian coordinates system; store in
6876 c   x_prime, y_prime and z_prime
6877 c
6878         do j=1,3
6879           x_prime(j) = 0.00
6880           y_prime(j) = 0.00
6881           z_prime(j) = 0.00
6882         enddo
6883 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6884 C     &   dc_norm(3,i+nres)
6885         do j = 1,3
6886           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6887           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6888         enddo
6889         do j = 1,3
6890           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6891         enddo
6892 c       write (2,*) "i",i
6893 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6894 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6895 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6896 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6897 c      & " xy",scalar(x_prime(1),y_prime(1)),
6898 c      & " xz",scalar(x_prime(1),z_prime(1)),
6899 c      & " yy",scalar(y_prime(1),y_prime(1)),
6900 c      & " yz",scalar(y_prime(1),z_prime(1)),
6901 c      & " zz",scalar(z_prime(1),z_prime(1))
6902 c
6903 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6904 C to local coordinate system. Store in xx, yy, zz.
6905 c
6906         xx=0.0d0
6907         yy=0.0d0
6908         zz=0.0d0
6909         do j = 1,3
6910           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6911           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6912           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6913         enddo
6914
6915         xxtab(i)=xx
6916         yytab(i)=yy
6917         zztab(i)=zz
6918 C
6919 C Compute the energy of the ith side cbain
6920 C
6921 c        write (2,*) "xx",xx," yy",yy," zz",zz
6922         it=iabs(itype(i))
6923         do j = 1,65
6924           x(j) = sc_parmin(j,it)
6925         enddo
6926 #ifdef CHECK_COORD
6927 Cc diagnostics - remove later
6928         xx1 = dcos(alph(2))
6929         yy1 = dsin(alph(2))*dcos(omeg(2))
6930         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6931         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6932      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6933      &    xx1,yy1,zz1
6934 C,"  --- ", xx_w,yy_w,zz_w
6935 c end diagnostics
6936 #endif
6937         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6938      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6939      &   + x(10)*yy*zz
6940         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6941      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6942      & + x(20)*yy*zz
6943         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6944      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6945      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6946      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6947      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6948      &  +x(40)*xx*yy*zz
6949         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6950      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6951      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6952      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6953      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6954      &  +x(60)*xx*yy*zz
6955         dsc_i   = 0.743d0+x(61)
6956         dp2_i   = 1.9d0+x(62)
6957         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6958      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6959         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6960      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6961         s1=(1+x(63))/(0.1d0 + dscp1)
6962         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6963         s2=(1+x(65))/(0.1d0 + dscp2)
6964         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6965         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6966      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6967 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6968 c     &   sumene4,
6969 c     &   dscp1,dscp2,sumene
6970 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6971         escloc = escloc + sumene
6972         if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
6973      &   " escloc",sumene,escloc,it,itype(i)
6974 c     & ,zz,xx,yy
6975 c#define DEBUG
6976 #ifdef DEBUG
6977 C
6978 C This section to check the numerical derivatives of the energy of ith side
6979 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6980 C #define DEBUG in the code to turn it on.
6981 C
6982         write (2,*) "sumene               =",sumene
6983         aincr=1.0d-7
6984         xxsave=xx
6985         xx=xx+aincr
6986         write (2,*) xx,yy,zz
6987         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6988         de_dxx_num=(sumenep-sumene)/aincr
6989         xx=xxsave
6990         write (2,*) "xx+ sumene from enesc=",sumenep
6991         yysave=yy
6992         yy=yy+aincr
6993         write (2,*) xx,yy,zz
6994         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6995         de_dyy_num=(sumenep-sumene)/aincr
6996         yy=yysave
6997         write (2,*) "yy+ sumene from enesc=",sumenep
6998         zzsave=zz
6999         zz=zz+aincr
7000         write (2,*) xx,yy,zz
7001         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7002         de_dzz_num=(sumenep-sumene)/aincr
7003         zz=zzsave
7004         write (2,*) "zz+ sumene from enesc=",sumenep
7005         costsave=cost2tab(i+1)
7006         sintsave=sint2tab(i+1)
7007         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7008         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7009         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7010         de_dt_num=(sumenep-sumene)/aincr
7011         write (2,*) " t+ sumene from enesc=",sumenep
7012         cost2tab(i+1)=costsave
7013         sint2tab(i+1)=sintsave
7014 C End of diagnostics section.
7015 #endif
7016 C
7017 C Compute the gradient of esc
7018 C
7019 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7020         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7021         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7022         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7023         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7024         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7025         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7026         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7027         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7028         pom1=(sumene3*sint2tab(i+1)+sumene1)
7029      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7030         pom2=(sumene4*cost2tab(i+1)+sumene2)
7031      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7032         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7033         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7034      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7035      &  +x(40)*yy*zz
7036         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7037         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7038      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7039      &  +x(60)*yy*zz
7040         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7041      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7042      &        +(pom1+pom2)*pom_dx
7043 #ifdef DEBUG
7044         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7045 #endif
7046 C
7047         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7048         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7049      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7050      &  +x(40)*xx*zz
7051         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7052         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7053      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7054      &  +x(59)*zz**2 +x(60)*xx*zz
7055         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7056      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7057      &        +(pom1-pom2)*pom_dy
7058 #ifdef DEBUG
7059         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7060 #endif
7061 C
7062         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7063      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7064      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7065      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7066      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7067      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7068      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7069      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7070 #ifdef DEBUG
7071         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7072 #endif
7073 C
7074         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7075      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7076      &  +pom1*pom_dt1+pom2*pom_dt2
7077 #ifdef DEBUG
7078         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7079 #endif
7080 c#undef DEBUG
7081 c
7082 C
7083        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7084        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7085        cosfac2xx=cosfac2*xx
7086        sinfac2yy=sinfac2*yy
7087        do k = 1,3
7088          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7089      &      vbld_inv(i+1)
7090          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7091      &      vbld_inv(i)
7092          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7093          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7094 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7095 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7096 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7097 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7098          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7099          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7100          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7101          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7102          dZZ_Ci1(k)=0.0d0
7103          dZZ_Ci(k)=0.0d0
7104          do j=1,3
7105            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7106      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7107            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7108      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7109          enddo
7110
7111          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7112          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7113          dZZ_XYZ(k)=vbld_inv(i+nres)*
7114      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7115 c
7116          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7117          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7118        enddo
7119
7120        do k=1,3
7121          dXX_Ctab(k,i)=dXX_Ci(k)
7122          dXX_C1tab(k,i)=dXX_Ci1(k)
7123          dYY_Ctab(k,i)=dYY_Ci(k)
7124          dYY_C1tab(k,i)=dYY_Ci1(k)
7125          dZZ_Ctab(k,i)=dZZ_Ci(k)
7126          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7127          dXX_XYZtab(k,i)=dXX_XYZ(k)
7128          dYY_XYZtab(k,i)=dYY_XYZ(k)
7129          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7130        enddo
7131
7132        do k = 1,3
7133 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7134 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7135 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7136 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7137 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7138 c     &    dt_dci(k)
7139 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7140 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7141          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7142      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7143          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7144      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7145          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7146      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7147        enddo
7148 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7149 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7150
7151 C to check gradient call subroutine check_grad
7152
7153     1 continue
7154       enddo
7155       return
7156       end
7157 c------------------------------------------------------------------------------
7158       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7159       implicit none
7160       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7161      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7162       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7163      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7164      &   + x(10)*yy*zz
7165       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7166      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7167      & + x(20)*yy*zz
7168       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7169      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7170      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7171      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7172      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7173      &  +x(40)*xx*yy*zz
7174       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7175      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7176      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7177      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7178      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7179      &  +x(60)*xx*yy*zz
7180       dsc_i   = 0.743d0+x(61)
7181       dp2_i   = 1.9d0+x(62)
7182       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7183      &          *(xx*cost2+yy*sint2))
7184       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7185      &          *(xx*cost2-yy*sint2))
7186       s1=(1+x(63))/(0.1d0 + dscp1)
7187       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7188       s2=(1+x(65))/(0.1d0 + dscp2)
7189       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7190       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7191      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7192       enesc=sumene
7193       return
7194       end
7195 #endif
7196 c------------------------------------------------------------------------------
7197       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7198 C
7199 C This procedure calculates two-body contact function g(rij) and its derivative:
7200 C
7201 C           eps0ij                                     !       x < -1
7202 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7203 C            0                                         !       x > 1
7204 C
7205 C where x=(rij-r0ij)/delta
7206 C
7207 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7208 C
7209       implicit none
7210       double precision rij,r0ij,eps0ij,fcont,fprimcont
7211       double precision x,x2,x4,delta
7212 c     delta=0.02D0*r0ij
7213 c      delta=0.2D0*r0ij
7214       x=(rij-r0ij)/delta
7215       if (x.lt.-1.0D0) then
7216         fcont=eps0ij
7217         fprimcont=0.0D0
7218       else if (x.le.1.0D0) then
7219         x2=x*x
7220         x4=x2*x2
7221         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7222         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7223       else
7224         fcont=0.0D0
7225         fprimcont=0.0D0
7226       endif
7227       return
7228       end
7229 c------------------------------------------------------------------------------
7230       subroutine splinthet(theti,delta,ss,ssder)
7231       implicit real*8 (a-h,o-z)
7232       include 'DIMENSIONS'
7233       include 'COMMON.VAR'
7234       include 'COMMON.GEO'
7235       thetup=pi-delta
7236       thetlow=delta
7237       if (theti.gt.pipol) then
7238         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7239       else
7240         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7241         ssder=-ssder
7242       endif
7243       return
7244       end
7245 c------------------------------------------------------------------------------
7246       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7247       implicit none
7248       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7249       double precision ksi,ksi2,ksi3,a1,a2,a3
7250       a1=fprim0*delta/(f1-f0)
7251       a2=3.0d0-2.0d0*a1
7252       a3=a1-2.0d0
7253       ksi=(x-x0)/delta
7254       ksi2=ksi*ksi
7255       ksi3=ksi2*ksi
7256       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7257       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7258       return
7259       end
7260 c------------------------------------------------------------------------------
7261       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7262       implicit none
7263       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7264       double precision ksi,ksi2,ksi3,a1,a2,a3
7265       ksi=(x-x0)/delta
7266       ksi2=ksi*ksi
7267       ksi3=ksi2*ksi
7268       a1=fprim0x*delta
7269       a2=3*(f1x-f0x)-2*fprim0x*delta
7270       a3=fprim0x*delta-2*(f1x-f0x)
7271       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7272       return
7273       end
7274 C-----------------------------------------------------------------------------
7275 #ifdef CRYST_TOR
7276 C-----------------------------------------------------------------------------
7277       subroutine etor(etors)
7278       implicit real*8 (a-h,o-z)
7279       include 'DIMENSIONS'
7280       include 'COMMON.VAR'
7281       include 'COMMON.GEO'
7282       include 'COMMON.LOCAL'
7283       include 'COMMON.TORSION'
7284       include 'COMMON.INTERACT'
7285       include 'COMMON.DERIV'
7286       include 'COMMON.CHAIN'
7287       include 'COMMON.NAMES'
7288       include 'COMMON.IOUNITS'
7289       include 'COMMON.FFIELD'
7290       include 'COMMON.TORCNSTR'
7291       include 'COMMON.CONTROL'
7292       logical lprn
7293 C Set lprn=.true. for debugging
7294       lprn=.false.
7295 c      lprn=.true.
7296       etors=0.0D0
7297       do i=iphi_start,iphi_end
7298       etors_ii=0.0D0
7299         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7300      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7301         itori=itortyp(itype(i-2))
7302         itori1=itortyp(itype(i-1))
7303         phii=phi(i)
7304         gloci=0.0D0
7305 C Proline-Proline pair is a special case...
7306         if (itori.eq.3 .and. itori1.eq.3) then
7307           if (phii.gt.-dwapi3) then
7308             cosphi=dcos(3*phii)
7309             fac=1.0D0/(1.0D0-cosphi)
7310             etorsi=v1(1,3,3)*fac
7311             etorsi=etorsi+etorsi
7312             etors=etors+etorsi-v1(1,3,3)
7313             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7314             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7315           endif
7316           do j=1,3
7317             v1ij=v1(j+1,itori,itori1)
7318             v2ij=v2(j+1,itori,itori1)
7319             cosphi=dcos(j*phii)
7320             sinphi=dsin(j*phii)
7321             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7322             if (energy_dec) etors_ii=etors_ii+
7323      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7324             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7325           enddo
7326         else
7327           do j=1,nterm_old
7328             v1ij=v1(j,itori,itori1)
7329             v2ij=v2(j,itori,itori1)
7330             cosphi=dcos(j*phii)
7331             sinphi=dsin(j*phii)
7332             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7333             if (energy_dec) etors_ii=etors_ii+
7334      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7335             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7336           enddo
7337         endif
7338         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7339              'etor',i,etors_ii
7340         if (lprn)
7341      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7342      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7343      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7344         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7345 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7346       enddo
7347       return
7348       end
7349 c------------------------------------------------------------------------------
7350       subroutine etor_d(etors_d)
7351       etors_d=0.0d0
7352       return
7353       end
7354 c----------------------------------------------------------------------------
7355 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7356       subroutine e_modeller(ehomology_constr)
7357       ehomology_constr=0.0d0
7358       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7359       return
7360       end
7361 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7362
7363 c------------------------------------------------------------------------------
7364       subroutine etor_d(etors_d)
7365       etors_d=0.0d0
7366       return
7367       end
7368 c----------------------------------------------------------------------------
7369 #else
7370       subroutine etor(etors)
7371       implicit real*8 (a-h,o-z)
7372       include 'DIMENSIONS'
7373       include 'COMMON.VAR'
7374       include 'COMMON.GEO'
7375       include 'COMMON.LOCAL'
7376       include 'COMMON.TORSION'
7377       include 'COMMON.INTERACT'
7378       include 'COMMON.DERIV'
7379       include 'COMMON.CHAIN'
7380       include 'COMMON.NAMES'
7381       include 'COMMON.IOUNITS'
7382       include 'COMMON.FFIELD'
7383       include 'COMMON.TORCNSTR'
7384       include 'COMMON.CONTROL'
7385       logical lprn
7386 C Set lprn=.true. for debugging
7387       lprn=.false.
7388 c     lprn=.true.
7389       etors=0.0D0
7390       do i=iphi_start,iphi_end
7391 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7392 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7393 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7394 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7395         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7396      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7397 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7398 C For introducing the NH3+ and COO- group please check the etor_d for reference
7399 C and guidance
7400         etors_ii=0.0D0
7401          if (iabs(itype(i)).eq.20) then
7402          iblock=2
7403          else
7404          iblock=1
7405          endif
7406         itori=itortyp(itype(i-2))
7407         itori1=itortyp(itype(i-1))
7408         phii=phi(i)
7409         gloci=0.0D0
7410 C Regular cosine and sine terms
7411         do j=1,nterm(itori,itori1,iblock)
7412           v1ij=v1(j,itori,itori1,iblock)
7413           v2ij=v2(j,itori,itori1,iblock)
7414           cosphi=dcos(j*phii)
7415           sinphi=dsin(j*phii)
7416           etors=etors+v1ij*cosphi+v2ij*sinphi
7417           if (energy_dec) etors_ii=etors_ii+
7418      &                v1ij*cosphi+v2ij*sinphi
7419           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7420         enddo
7421 C Lorentz terms
7422 C                         v1
7423 C  E = SUM ----------------------------------- - v1
7424 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7425 C
7426         cosphi=dcos(0.5d0*phii)
7427         sinphi=dsin(0.5d0*phii)
7428         do j=1,nlor(itori,itori1,iblock)
7429           vl1ij=vlor1(j,itori,itori1)
7430           vl2ij=vlor2(j,itori,itori1)
7431           vl3ij=vlor3(j,itori,itori1)
7432           pom=vl2ij*cosphi+vl3ij*sinphi
7433           pom1=1.0d0/(pom*pom+1.0d0)
7434           etors=etors+vl1ij*pom1
7435           if (energy_dec) etors_ii=etors_ii+
7436      &                vl1ij*pom1
7437           pom=-pom*pom1*pom1
7438           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7439         enddo
7440 C Subtract the constant term
7441         etors=etors-v0(itori,itori1,iblock)
7442           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7443      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7444         if (lprn)
7445      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7446      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7447      &  (v1(j,itori,itori1,iblock),j=1,6),
7448      &  (v2(j,itori,itori1,iblock),j=1,6)
7449         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7450 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7451       enddo
7452       return
7453       end
7454 c----------------------------------------------------------------------------
7455       subroutine etor_d(etors_d)
7456 C 6/23/01 Compute double torsional energy
7457       implicit real*8 (a-h,o-z)
7458       include 'DIMENSIONS'
7459       include 'COMMON.VAR'
7460       include 'COMMON.GEO'
7461       include 'COMMON.LOCAL'
7462       include 'COMMON.TORSION'
7463       include 'COMMON.INTERACT'
7464       include 'COMMON.DERIV'
7465       include 'COMMON.CHAIN'
7466       include 'COMMON.NAMES'
7467       include 'COMMON.IOUNITS'
7468       include 'COMMON.FFIELD'
7469       include 'COMMON.TORCNSTR'
7470       logical lprn
7471 C Set lprn=.true. for debugging
7472       lprn=.false.
7473 c     lprn=.true.
7474       etors_d=0.0D0
7475 c      write(iout,*) "a tu??"
7476       do i=iphid_start,iphid_end
7477 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7478 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7479 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7480 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7481 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7482          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7483      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7484      &  (itype(i+1).eq.ntyp1)) cycle
7485 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7486         itori=itortyp(itype(i-2))
7487         itori1=itortyp(itype(i-1))
7488         itori2=itortyp(itype(i))
7489         phii=phi(i)
7490         phii1=phi(i+1)
7491         gloci1=0.0D0
7492         gloci2=0.0D0
7493         iblock=1
7494         if (iabs(itype(i+1)).eq.20) iblock=2
7495 C Iblock=2 Proline type
7496 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7497 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7498 C        if (itype(i+1).eq.ntyp1) iblock=3
7499 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7500 C IS or IS NOT need for this
7501 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7502 C        is (itype(i-3).eq.ntyp1) ntblock=2
7503 C        ntblock is N-terminal blocking group
7504
7505 C Regular cosine and sine terms
7506         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7507 C Example of changes for NH3+ blocking group
7508 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7509 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7510           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7511           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7512           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7513           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7514           cosphi1=dcos(j*phii)
7515           sinphi1=dsin(j*phii)
7516           cosphi2=dcos(j*phii1)
7517           sinphi2=dsin(j*phii1)
7518           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7519      &     v2cij*cosphi2+v2sij*sinphi2
7520           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7521           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7522         enddo
7523         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7524           do l=1,k-1
7525             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7526             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7527             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7528             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7529             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7530             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7531             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7532             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7533             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7534      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7535             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7536      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7537             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7538      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7539           enddo
7540         enddo
7541         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7542         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7543       enddo
7544       return
7545       end
7546 #endif
7547 C----------------------------------------------------------------------------------
7548 C The rigorous attempt to derive energy function
7549       subroutine etor_kcc(etors)
7550       implicit real*8 (a-h,o-z)
7551       include 'DIMENSIONS'
7552       include 'COMMON.VAR'
7553       include 'COMMON.GEO'
7554       include 'COMMON.LOCAL'
7555       include 'COMMON.TORSION'
7556       include 'COMMON.INTERACT'
7557       include 'COMMON.DERIV'
7558       include 'COMMON.CHAIN'
7559       include 'COMMON.NAMES'
7560       include 'COMMON.IOUNITS'
7561       include 'COMMON.FFIELD'
7562       include 'COMMON.TORCNSTR'
7563       include 'COMMON.CONTROL'
7564       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7565       logical lprn
7566 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7567 C Set lprn=.true. for debugging
7568       lprn=energy_dec
7569 c     lprn=.true.
7570 C      print *,"wchodze kcc"
7571       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7572       etors=0.0D0
7573       do i=iphi_start,iphi_end
7574 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7575 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7576 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7577 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7578         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7579      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7580         itori=itortyp(itype(i-2))
7581         itori1=itortyp(itype(i-1))
7582         phii=phi(i)
7583         glocig=0.0D0
7584         glocit1=0.0d0
7585         glocit2=0.0d0
7586 C to avoid multiple devision by 2
7587 c        theti22=0.5d0*theta(i)
7588 C theta 12 is the theta_1 /2
7589 C theta 22 is theta_2 /2
7590 c        theti12=0.5d0*theta(i-1)
7591 C and appropriate sinus function
7592         sinthet1=dsin(theta(i-1))
7593         sinthet2=dsin(theta(i))
7594         costhet1=dcos(theta(i-1))
7595         costhet2=dcos(theta(i))
7596 C to speed up lets store its mutliplication
7597         sint1t2=sinthet2*sinthet1
7598         sint1t2n=1.0d0
7599 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7600 C +d_n*sin(n*gamma)) *
7601 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7602 C we have two sum 1) Non-Chebyshev which is with n and gamma
7603         nval=nterm_kcc_Tb(itori,itori1)
7604         c1(0)=0.0d0
7605         c2(0)=0.0d0
7606         c1(1)=1.0d0
7607         c2(1)=1.0d0
7608         do j=2,nval
7609           c1(j)=c1(j-1)*costhet1
7610           c2(j)=c2(j-1)*costhet2
7611         enddo
7612         etori=0.0d0
7613         do j=1,nterm_kcc(itori,itori1)
7614           cosphi=dcos(j*phii)
7615           sinphi=dsin(j*phii)
7616           sint1t2n1=sint1t2n
7617           sint1t2n=sint1t2n*sint1t2
7618           sumvalc=0.0d0
7619           gradvalct1=0.0d0
7620           gradvalct2=0.0d0
7621           do k=1,nval
7622             do l=1,nval
7623               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7624               gradvalct1=gradvalct1+
7625      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7626               gradvalct2=gradvalct2+
7627      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7628             enddo
7629           enddo
7630           gradvalct1=-gradvalct1*sinthet1
7631           gradvalct2=-gradvalct2*sinthet2
7632           sumvals=0.0d0
7633           gradvalst1=0.0d0
7634           gradvalst2=0.0d0
7635           do k=1,nval
7636             do l=1,nval
7637               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7638               gradvalst1=gradvalst1+
7639      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7640               gradvalst2=gradvalst2+
7641      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7642             enddo
7643           enddo
7644           gradvalst1=-gradvalst1*sinthet1
7645           gradvalst2=-gradvalst2*sinthet2
7646           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7647           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7648 C glocig is the gradient local i site in gamma
7649           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7650 C now gradient over theta_1
7651           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7652      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7653           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7654      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7655         enddo ! j
7656         etors=etors+etori
7657 C derivative over gamma
7658         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7659 C derivative over theta1
7660         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7661 C now derivative over theta2
7662         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7663         if (lprn) then
7664           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7665      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7666           write (iout,*) "c1",(c1(k),k=0,nval),
7667      &    " c2",(c2(k),k=0,nval)
7668         endif
7669       enddo
7670       return
7671       end
7672 c---------------------------------------------------------------------------------------------
7673       subroutine etor_constr(edihcnstr)
7674       implicit real*8 (a-h,o-z)
7675       include 'DIMENSIONS'
7676       include 'COMMON.VAR'
7677       include 'COMMON.GEO'
7678       include 'COMMON.LOCAL'
7679       include 'COMMON.TORSION'
7680       include 'COMMON.INTERACT'
7681       include 'COMMON.DERIV'
7682       include 'COMMON.CHAIN'
7683       include 'COMMON.NAMES'
7684       include 'COMMON.IOUNITS'
7685       include 'COMMON.FFIELD'
7686       include 'COMMON.TORCNSTR'
7687       include 'COMMON.BOUNDS'
7688       include 'COMMON.CONTROL'
7689 ! 6/20/98 - dihedral angle constraints
7690       edihcnstr=0.0d0
7691 c      do i=1,ndih_constr
7692       if (raw_psipred) then
7693         do i=idihconstr_start,idihconstr_end
7694           itori=idih_constr(i)
7695           phii=phi(itori)
7696           gaudih_i=vpsipred(1,i)
7697           gauder_i=0.0d0
7698           do j=1,2
7699             s = sdihed(j,i)
7700             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7701             dexpcos_i=dexp(-cos_i*cos_i)
7702             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7703             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7704      &            *cos_i*dexpcos_i/s**2
7705           enddo
7706           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7707           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7708           if (energy_dec)
7709      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7710      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7711      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7712      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7713      &     -wdihc*dlog(gaudih_i)
7714         enddo
7715       else
7716
7717       do i=idihconstr_start,idihconstr_end
7718         itori=idih_constr(i)
7719         phii=phi(itori)
7720         difi=pinorm(phii-phi0(i))
7721         if (difi.gt.drange(i)) then
7722           difi=difi-drange(i)
7723           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7724           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7725         else if (difi.lt.-drange(i)) then
7726           difi=difi+drange(i)
7727           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7728           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7729         else
7730           difi=0.0
7731         endif
7732       enddo
7733
7734       endif
7735
7736       return
7737       end
7738 c----------------------------------------------------------------------------
7739 c MODELLER restraint function
7740       subroutine e_modeller(ehomology_constr)
7741       implicit none
7742       include 'DIMENSIONS'
7743
7744       double precision ehomology_constr
7745       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7746       integer katy, odleglosci, test7
7747       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7748       real*8 Eval,Erot
7749       real*8 distance(max_template),distancek(max_template),
7750      &    min_odl,godl(max_template),dih_diff(max_template)
7751
7752 c
7753 c     FP - 30/10/2014 Temporary specifications for homology restraints
7754 c
7755       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7756      &                 sgtheta
7757       double precision, dimension (maxres) :: guscdiff,usc_diff
7758       double precision, dimension (max_template) ::
7759      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7760      &           theta_diff
7761       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7762      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7763      & betai,sum_sgodl,dij
7764       double precision dist,pinorm
7765 c
7766       include 'COMMON.SBRIDGE'
7767       include 'COMMON.CHAIN'
7768       include 'COMMON.GEO'
7769       include 'COMMON.DERIV'
7770       include 'COMMON.LOCAL'
7771       include 'COMMON.INTERACT'
7772       include 'COMMON.VAR'
7773       include 'COMMON.IOUNITS'
7774 c      include 'COMMON.MD'
7775       include 'COMMON.CONTROL'
7776       include 'COMMON.HOMOLOGY'
7777       include 'COMMON.QRESTR'
7778 c
7779 c     From subroutine Econstr_back
7780 c
7781       include 'COMMON.NAMES'
7782       include 'COMMON.TIME1'
7783 c
7784
7785
7786       do i=1,max_template
7787         distancek(i)=9999999.9
7788       enddo
7789
7790
7791       odleg=0.0d0
7792
7793 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7794 c function)
7795 C AL 5/2/14 - Introduce list of restraints
7796 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7797 #ifdef DEBUG
7798       write(iout,*) "------- dist restrs start -------"
7799 #endif
7800       do ii = link_start_homo,link_end_homo
7801          i = ires_homo(ii)
7802          j = jres_homo(ii)
7803          dij=dist(i,j)
7804 c        write (iout,*) "dij(",i,j,") =",dij
7805          nexl=0
7806          do k=1,constr_homology
7807 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7808            if(.not.l_homo(k,ii)) then
7809              nexl=nexl+1
7810              cycle
7811            endif
7812            distance(k)=odl(k,ii)-dij
7813 c          write (iout,*) "distance(",k,") =",distance(k)
7814 c
7815 c          For Gaussian-type Urestr
7816 c
7817            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7818 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7819 c          write (iout,*) "distancek(",k,") =",distancek(k)
7820 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7821 c
7822 c          For Lorentzian-type Urestr
7823 c
7824            if (waga_dist.lt.0.0d0) then
7825               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7826               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7827      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
7828            endif
7829          enddo
7830
7831 c         min_odl=minval(distancek)
7832          if (nexl.gt.0) then
7833            min_odl=0.0d0
7834          else
7835            do kk=1,constr_homology
7836             if(l_homo(kk,ii)) then
7837               min_odl=distancek(kk)
7838               exit
7839             endif
7840            enddo
7841            do kk=1,constr_homology
7842             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7843      &              min_odl=distancek(kk)
7844            enddo
7845          endif
7846
7847 c        write (iout,* )"min_odl",min_odl
7848 #ifdef DEBUG
7849          write (iout,*) "ij dij",i,j,dij
7850          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7851          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7852          write (iout,* )"min_odl",min_odl
7853 #endif
7854 #ifdef OLDRESTR
7855          odleg2=0.0d0
7856 #else
7857          if (waga_dist.ge.0.0d0) then
7858            odleg2=nexl
7859          else
7860            odleg2=0.0d0
7861          endif
7862 #endif
7863          do k=1,constr_homology
7864 c Nie wiem po co to liczycie jeszcze raz!
7865 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7866 c     &              (2*(sigma_odl(i,j,k))**2))
7867            if(.not.l_homo(k,ii)) cycle
7868            if (waga_dist.ge.0.0d0) then
7869 c
7870 c          For Gaussian-type Urestr
7871 c
7872             godl(k)=dexp(-distancek(k)+min_odl)
7873             odleg2=odleg2+godl(k)
7874 c
7875 c          For Lorentzian-type Urestr
7876 c
7877            else
7878             odleg2=odleg2+distancek(k)
7879            endif
7880
7881 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7882 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7883 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7884 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7885
7886          enddo
7887 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7888 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7889 #ifdef DEBUG
7890          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7891          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7892 #endif
7893            if (waga_dist.ge.0.0d0) then
7894 c
7895 c          For Gaussian-type Urestr
7896 c
7897               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7898 c
7899 c          For Lorentzian-type Urestr
7900 c
7901            else
7902               odleg=odleg+odleg2/constr_homology
7903            endif
7904 c
7905 c        write (iout,*) "odleg",odleg ! sum of -ln-s
7906 c Gradient
7907 c
7908 c          For Gaussian-type Urestr
7909 c
7910          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7911          sum_sgodl=0.0d0
7912          do k=1,constr_homology
7913 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7914 c     &           *waga_dist)+min_odl
7915 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7916 c
7917          if(.not.l_homo(k,ii)) cycle
7918          if (waga_dist.ge.0.0d0) then
7919 c          For Gaussian-type Urestr
7920 c
7921            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7922 c
7923 c          For Lorentzian-type Urestr
7924 c
7925          else
7926            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7927      &           sigma_odlir(k,ii)**2)**2)
7928          endif
7929            sum_sgodl=sum_sgodl+sgodl
7930
7931 c            sgodl2=sgodl2+sgodl
7932 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7933 c      write(iout,*) "constr_homology=",constr_homology
7934 c      write(iout,*) i, j, k, "TEST K"
7935          enddo
7936          if (waga_dist.ge.0.0d0) then
7937 c
7938 c          For Gaussian-type Urestr
7939 c
7940             grad_odl3=waga_homology(iset)*waga_dist
7941      &                *sum_sgodl/(sum_godl*dij)
7942 c
7943 c          For Lorentzian-type Urestr
7944 c
7945          else
7946 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7947 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7948             grad_odl3=-waga_homology(iset)*waga_dist*
7949      &                sum_sgodl/(constr_homology*dij)
7950          endif
7951 c
7952 c        grad_odl3=sum_sgodl/(sum_godl*dij)
7953
7954
7955 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7956 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7957 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7958
7959 ccc      write(iout,*) godl, sgodl, grad_odl3
7960
7961 c          grad_odl=grad_odl+grad_odl3
7962
7963          do jik=1,3
7964             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7965 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7966 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7967 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7968             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7969             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7970 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7971 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7972 c         if (i.eq.25.and.j.eq.27) then
7973 c         write(iout,*) "jik",jik,"i",i,"j",j
7974 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7975 c         write(iout,*) "grad_odl3",grad_odl3
7976 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7977 c         write(iout,*) "ggodl",ggodl
7978 c         write(iout,*) "ghpbc(",jik,i,")",
7979 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7980 c     &                 ghpbc(jik,j)
7981 c         endif
7982          enddo
7983 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7984 ccc     & dLOG(odleg2),"-odleg=", -odleg
7985
7986       enddo ! ii-loop for dist
7987 #ifdef DEBUG
7988       write(iout,*) "------- dist restrs end -------"
7989 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7990 c    &     waga_d.eq.1.0d0) call sum_gradient
7991 #endif
7992 c Pseudo-energy and gradient from dihedral-angle restraints from
7993 c homology templates
7994 c      write (iout,*) "End of distance loop"
7995 c      call flush(iout)
7996       kat=0.0d0
7997 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7998 #ifdef DEBUG
7999       write(iout,*) "------- dih restrs start -------"
8000       do i=idihconstr_start_homo,idihconstr_end_homo
8001         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8002       enddo
8003 #endif
8004       do i=idihconstr_start_homo,idihconstr_end_homo
8005         kat2=0.0d0
8006 c        betai=beta(i,i+1,i+2,i+3)
8007         betai = phi(i)
8008 c       write (iout,*) "betai =",betai
8009         do k=1,constr_homology
8010           dih_diff(k)=pinorm(dih(k,i)-betai)
8011 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8012 cd     &                  ,sigma_dih(k,i)
8013 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8014 c     &                                   -(6.28318-dih_diff(i,k))
8015 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8016 c     &                                   6.28318+dih_diff(i,k)
8017 #ifdef OLD_DIHED
8018           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8019 #else
8020           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8021 #endif
8022 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8023           gdih(k)=dexp(kat3)
8024           kat2=kat2+gdih(k)
8025 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8026 c          write(*,*)""
8027         enddo
8028 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8029 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8030 #ifdef DEBUG
8031         write (iout,*) "i",i," betai",betai," kat2",kat2
8032         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8033 #endif
8034         if (kat2.le.1.0d-14) cycle
8035         kat=kat-dLOG(kat2/constr_homology)
8036 c       write (iout,*) "kat",kat ! sum of -ln-s
8037
8038 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8039 ccc     & dLOG(kat2), "-kat=", -kat
8040
8041 c ----------------------------------------------------------------------
8042 c Gradient
8043 c ----------------------------------------------------------------------
8044
8045         sum_gdih=kat2
8046         sum_sgdih=0.0d0
8047         do k=1,constr_homology
8048 #ifdef OLD_DIHED
8049           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8050 #else
8051           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8052 #endif
8053 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8054           sum_sgdih=sum_sgdih+sgdih
8055         enddo
8056 c       grad_dih3=sum_sgdih/sum_gdih
8057         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8058
8059 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8060 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8061 ccc     & gloc(nphi+i-3,icg)
8062         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8063 c        if (i.eq.25) then
8064 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8065 c        endif
8066 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8067 ccc     & gloc(nphi+i-3,icg)
8068
8069       enddo ! i-loop for dih
8070 #ifdef DEBUG
8071       write(iout,*) "------- dih restrs end -------"
8072 #endif
8073
8074 c Pseudo-energy and gradient for theta angle restraints from
8075 c homology templates
8076 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8077 c adapted
8078
8079 c
8080 c     For constr_homology reference structures (FP)
8081 c
8082 c     Uconst_back_tot=0.0d0
8083       Eval=0.0d0
8084       Erot=0.0d0
8085 c     Econstr_back legacy
8086       do i=1,nres
8087 c     do i=ithet_start,ithet_end
8088        dutheta(i)=0.0d0
8089 c     enddo
8090 c     do i=loc_start,loc_end
8091         do j=1,3
8092           duscdiff(j,i)=0.0d0
8093           duscdiffx(j,i)=0.0d0
8094         enddo
8095       enddo
8096 c
8097 c     do iref=1,nref
8098 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8099 c     write (iout,*) "waga_theta",waga_theta
8100       if (waga_theta.gt.0.0d0) then
8101 #ifdef DEBUG
8102       write (iout,*) "usampl",usampl
8103       write(iout,*) "------- theta restrs start -------"
8104 c     do i=ithet_start,ithet_end
8105 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8106 c     enddo
8107 #endif
8108 c     write (iout,*) "maxres",maxres,"nres",nres
8109
8110       do i=ithet_start,ithet_end
8111 c
8112 c     do i=1,nfrag_back
8113 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8114 c
8115 c Deviation of theta angles wrt constr_homology ref structures
8116 c
8117         utheta_i=0.0d0 ! argument of Gaussian for single k
8118         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8119 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8120 c       over residues in a fragment
8121 c       write (iout,*) "theta(",i,")=",theta(i)
8122         do k=1,constr_homology
8123 c
8124 c         dtheta_i=theta(j)-thetaref(j,iref)
8125 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8126           theta_diff(k)=thetatpl(k,i)-theta(i)
8127 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8128 cd     &                  ,sigma_theta(k,i)
8129
8130 c
8131           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8132 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8133           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8134           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8135 c         Gradient for single Gaussian restraint in subr Econstr_back
8136 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8137 c
8138         enddo
8139 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8140 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8141
8142 c
8143 c         Gradient for multiple Gaussian restraint
8144         sum_gtheta=gutheta_i
8145         sum_sgtheta=0.0d0
8146         do k=1,constr_homology
8147 c        New generalized expr for multiple Gaussian from Econstr_back
8148          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8149 c
8150 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8151           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8152         enddo
8153 c       Final value of gradient using same var as in Econstr_back
8154         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8155      &      +sum_sgtheta/sum_gtheta*waga_theta
8156      &               *waga_homology(iset)
8157 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8158 c     &               *waga_homology(iset)
8159 c       dutheta(i)=sum_sgtheta/sum_gtheta
8160 c
8161 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8162         Eval=Eval-dLOG(gutheta_i/constr_homology)
8163 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8164 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8165 c       Uconst_back=Uconst_back+utheta(i)
8166       enddo ! (i-loop for theta)
8167 #ifdef DEBUG
8168       write(iout,*) "------- theta restrs end -------"
8169 #endif
8170       endif
8171 c
8172 c Deviation of local SC geometry
8173 c
8174 c Separation of two i-loops (instructed by AL - 11/3/2014)
8175 c
8176 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8177 c     write (iout,*) "waga_d",waga_d
8178
8179 #ifdef DEBUG
8180       write(iout,*) "------- SC restrs start -------"
8181       write (iout,*) "Initial duscdiff,duscdiffx"
8182       do i=loc_start,loc_end
8183         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8184      &                 (duscdiffx(jik,i),jik=1,3)
8185       enddo
8186 #endif
8187       do i=loc_start,loc_end
8188         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8189         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8190 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8191 c       write(iout,*) "xxtab, yytab, zztab"
8192 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8193         do k=1,constr_homology
8194 c
8195           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8196 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8197           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8198           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8199 c         write(iout,*) "dxx, dyy, dzz"
8200 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8201 c
8202           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8203 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8204 c         uscdiffk(k)=usc_diff(i)
8205           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8206 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8207 c     &       " guscdiff2",guscdiff2(k)
8208           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8209 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8210 c     &      xxref(j),yyref(j),zzref(j)
8211         enddo
8212 c
8213 c       Gradient
8214 c
8215 c       Generalized expression for multiple Gaussian acc to that for a single
8216 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8217 c
8218 c       Original implementation
8219 c       sum_guscdiff=guscdiff(i)
8220 c
8221 c       sum_sguscdiff=0.0d0
8222 c       do k=1,constr_homology
8223 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8224 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8225 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8226 c       enddo
8227 c
8228 c       Implementation of new expressions for gradient (Jan. 2015)
8229 c
8230 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8231         do k=1,constr_homology
8232 c
8233 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8234 c       before. Now the drivatives should be correct
8235 c
8236           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8237 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8238           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8239           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8240 c
8241 c         New implementation
8242 c
8243           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8244      &                 sigma_d(k,i) ! for the grad wrt r'
8245 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8246 c
8247 c
8248 c        New implementation
8249          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8250          do jik=1,3
8251             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8252      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8253      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8254             duscdiff(jik,i)=duscdiff(jik,i)+
8255      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8256      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8257             duscdiffx(jik,i)=duscdiffx(jik,i)+
8258      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8259      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8260 c
8261 #ifdef DEBUG
8262              write(iout,*) "jik",jik,"i",i
8263              write(iout,*) "dxx, dyy, dzz"
8264              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8265              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8266 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8267 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8268 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8269 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8270 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8271 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8272 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8273 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8274 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8275 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8276 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8277 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8278 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8279 c            endif
8280 #endif
8281          enddo
8282         enddo
8283 c
8284 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8285 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8286 c
8287 c        write (iout,*) i," uscdiff",uscdiff(i)
8288 c
8289 c Put together deviations from local geometry
8290
8291 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8292 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8293         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8294 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8295 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8296 c       Uconst_back=Uconst_back+usc_diff(i)
8297 c
8298 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8299 c
8300 c     New implment: multiplied by sum_sguscdiff
8301 c
8302
8303       enddo ! (i-loop for dscdiff)
8304
8305 c      endif
8306
8307 #ifdef DEBUG
8308       write(iout,*) "------- SC restrs end -------"
8309         write (iout,*) "------ After SC loop in e_modeller ------"
8310         do i=loc_start,loc_end
8311          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8312          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8313         enddo
8314       if (waga_theta.eq.1.0d0) then
8315       write (iout,*) "in e_modeller after SC restr end: dutheta"
8316       do i=ithet_start,ithet_end
8317         write (iout,*) i,dutheta(i)
8318       enddo
8319       endif
8320       if (waga_d.eq.1.0d0) then
8321       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8322       do i=1,nres
8323         write (iout,*) i,(duscdiff(j,i),j=1,3)
8324         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8325       enddo
8326       endif
8327 #endif
8328
8329 c Total energy from homology restraints
8330 #ifdef DEBUG
8331       write (iout,*) "odleg",odleg," kat",kat
8332 #endif
8333 c
8334 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8335 c
8336 c     ehomology_constr=odleg+kat
8337 c
8338 c     For Lorentzian-type Urestr
8339 c
8340
8341       if (waga_dist.ge.0.0d0) then
8342 c
8343 c          For Gaussian-type Urestr
8344 c
8345         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8346      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8347 c     write (iout,*) "ehomology_constr=",ehomology_constr
8348       else
8349 c
8350 c          For Lorentzian-type Urestr
8351 c
8352         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8353      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8354 c     write (iout,*) "ehomology_constr=",ehomology_constr
8355       endif
8356 #ifdef DEBUG
8357       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8358      & "Eval",waga_theta,eval,
8359      &   "Erot",waga_d,Erot
8360       write (iout,*) "ehomology_constr",ehomology_constr
8361 #endif
8362       return
8363 c
8364 c FP 01/15 end
8365 c
8366   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8367   747 format(a12,i4,i4,i4,f8.3,f8.3)
8368   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8369   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8370   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8371      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8372       end
8373 c----------------------------------------------------------------------------
8374 C The rigorous attempt to derive energy function
8375       subroutine ebend_kcc(etheta)
8376
8377       implicit real*8 (a-h,o-z)
8378       include 'DIMENSIONS'
8379       include 'COMMON.VAR'
8380       include 'COMMON.GEO'
8381       include 'COMMON.LOCAL'
8382       include 'COMMON.TORSION'
8383       include 'COMMON.INTERACT'
8384       include 'COMMON.DERIV'
8385       include 'COMMON.CHAIN'
8386       include 'COMMON.NAMES'
8387       include 'COMMON.IOUNITS'
8388       include 'COMMON.FFIELD'
8389       include 'COMMON.TORCNSTR'
8390       include 'COMMON.CONTROL'
8391       logical lprn
8392       double precision thybt1(maxang_kcc)
8393 C Set lprn=.true. for debugging
8394       lprn=energy_dec
8395 c     lprn=.true.
8396 C      print *,"wchodze kcc"
8397       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8398       etheta=0.0D0
8399       do i=ithet_start,ithet_end
8400 c        print *,i,itype(i-1),itype(i),itype(i-2)
8401         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8402      &  .or.itype(i).eq.ntyp1) cycle
8403         iti=iabs(itortyp(itype(i-1)))
8404         sinthet=dsin(theta(i))
8405         costhet=dcos(theta(i))
8406         do j=1,nbend_kcc_Tb(iti)
8407           thybt1(j)=v1bend_chyb(j,iti)
8408         enddo
8409         sumth1thyb=v1bend_chyb(0,iti)+
8410      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8411         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8412      &    sumth1thyb
8413         ihelp=nbend_kcc_Tb(iti)-1
8414         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8415         etheta=etheta+sumth1thyb
8416 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8417         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8418       enddo
8419       return
8420       end
8421 c-------------------------------------------------------------------------------------
8422       subroutine etheta_constr(ethetacnstr)
8423
8424       implicit real*8 (a-h,o-z)
8425       include 'DIMENSIONS'
8426       include 'COMMON.VAR'
8427       include 'COMMON.GEO'
8428       include 'COMMON.LOCAL'
8429       include 'COMMON.TORSION'
8430       include 'COMMON.INTERACT'
8431       include 'COMMON.DERIV'
8432       include 'COMMON.CHAIN'
8433       include 'COMMON.NAMES'
8434       include 'COMMON.IOUNITS'
8435       include 'COMMON.FFIELD'
8436       include 'COMMON.TORCNSTR'
8437       include 'COMMON.CONTROL'
8438       ethetacnstr=0.0d0
8439 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8440       do i=ithetaconstr_start,ithetaconstr_end
8441         itheta=itheta_constr(i)
8442         thetiii=theta(itheta)
8443         difi=pinorm(thetiii-theta_constr0(i))
8444         if (difi.gt.theta_drange(i)) then
8445           difi=difi-theta_drange(i)
8446           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8447           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8448      &    +for_thet_constr(i)*difi**3
8449         else if (difi.lt.-drange(i)) then
8450           difi=difi+drange(i)
8451           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8452           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8453      &    +for_thet_constr(i)*difi**3
8454         else
8455           difi=0.0
8456         endif
8457        if (energy_dec) then
8458         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8459      &    i,itheta,rad2deg*thetiii,
8460      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8461      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8462      &    gloc(itheta+nphi-2,icg)
8463         endif
8464       enddo
8465       return
8466       end
8467 c------------------------------------------------------------------------------
8468       subroutine eback_sc_corr(esccor)
8469 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8470 c        conformational states; temporarily implemented as differences
8471 c        between UNRES torsional potentials (dependent on three types of
8472 c        residues) and the torsional potentials dependent on all 20 types
8473 c        of residues computed from AM1  energy surfaces of terminally-blocked
8474 c        amino-acid residues.
8475       implicit real*8 (a-h,o-z)
8476       include 'DIMENSIONS'
8477       include 'COMMON.VAR'
8478       include 'COMMON.GEO'
8479       include 'COMMON.LOCAL'
8480       include 'COMMON.TORSION'
8481       include 'COMMON.SCCOR'
8482       include 'COMMON.INTERACT'
8483       include 'COMMON.DERIV'
8484       include 'COMMON.CHAIN'
8485       include 'COMMON.NAMES'
8486       include 'COMMON.IOUNITS'
8487       include 'COMMON.FFIELD'
8488       include 'COMMON.CONTROL'
8489       logical lprn
8490 C Set lprn=.true. for debugging
8491       lprn=.false.
8492 c      lprn=.true.
8493 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8494       esccor=0.0D0
8495       do i=itau_start,itau_end
8496         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8497         esccor_ii=0.0D0
8498         isccori=isccortyp(itype(i-2))
8499         isccori1=isccortyp(itype(i-1))
8500 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8501         phii=phi(i)
8502         do intertyp=1,3 !intertyp
8503 cc Added 09 May 2012 (Adasko)
8504 cc  Intertyp means interaction type of backbone mainchain correlation:
8505 c   1 = SC...Ca...Ca...Ca
8506 c   2 = Ca...Ca...Ca...SC
8507 c   3 = SC...Ca...Ca...SCi
8508         gloci=0.0D0
8509         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8510      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8511      &      (itype(i-1).eq.ntyp1)))
8512      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8513      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8514      &     .or.(itype(i).eq.ntyp1)))
8515      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8516      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8517      &      (itype(i-3).eq.ntyp1)))) cycle
8518         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8519         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8520      & cycle
8521        do j=1,nterm_sccor(isccori,isccori1)
8522           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8523           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8524           cosphi=dcos(j*tauangle(intertyp,i))
8525           sinphi=dsin(j*tauangle(intertyp,i))
8526           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8527           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8528         enddo
8529 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8530         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8531         if (lprn)
8532      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8533      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8534      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8535      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8536         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8537        enddo !intertyp
8538       enddo
8539
8540       return
8541       end
8542 #ifdef FOURBODY
8543 c----------------------------------------------------------------------------
8544       subroutine multibody(ecorr)
8545 C This subroutine calculates multi-body contributions to energy following
8546 C the idea of Skolnick et al. If side chains I and J make a contact and
8547 C at the same time side chains I+1 and J+1 make a contact, an extra
8548 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8549       implicit real*8 (a-h,o-z)
8550       include 'DIMENSIONS'
8551       include 'COMMON.IOUNITS'
8552       include 'COMMON.DERIV'
8553       include 'COMMON.INTERACT'
8554       include 'COMMON.CONTACTS'
8555       include 'COMMON.CONTMAT'
8556       include 'COMMON.CORRMAT'
8557       double precision gx(3),gx1(3)
8558       logical lprn
8559
8560 C Set lprn=.true. for debugging
8561       lprn=.false.
8562
8563       if (lprn) then
8564         write (iout,'(a)') 'Contact function values:'
8565         do i=nnt,nct-2
8566           write (iout,'(i2,20(1x,i2,f10.5))')
8567      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8568         enddo
8569       endif
8570       ecorr=0.0D0
8571       do i=nnt,nct
8572         do j=1,3
8573           gradcorr(j,i)=0.0D0
8574           gradxorr(j,i)=0.0D0
8575         enddo
8576       enddo
8577       do i=nnt,nct-2
8578
8579         DO ISHIFT = 3,4
8580
8581         i1=i+ishift
8582         num_conti=num_cont(i)
8583         num_conti1=num_cont(i1)
8584         do jj=1,num_conti
8585           j=jcont(jj,i)
8586           do kk=1,num_conti1
8587             j1=jcont(kk,i1)
8588             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8589 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8590 cd   &                   ' ishift=',ishift
8591 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8592 C The system gains extra energy.
8593               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8594             endif   ! j1==j+-ishift
8595           enddo     ! kk
8596         enddo       ! jj
8597
8598         ENDDO ! ISHIFT
8599
8600       enddo         ! i
8601       return
8602       end
8603 c------------------------------------------------------------------------------
8604       double precision function esccorr(i,j,k,l,jj,kk)
8605       implicit real*8 (a-h,o-z)
8606       include 'DIMENSIONS'
8607       include 'COMMON.IOUNITS'
8608       include 'COMMON.DERIV'
8609       include 'COMMON.INTERACT'
8610       include 'COMMON.CONTACTS'
8611       include 'COMMON.CONTMAT'
8612       include 'COMMON.CORRMAT'
8613       include 'COMMON.SHIELD'
8614       double precision gx(3),gx1(3)
8615       logical lprn
8616       lprn=.false.
8617       eij=facont(jj,i)
8618       ekl=facont(kk,k)
8619 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8620 C Calculate the multi-body contribution to energy.
8621 C Calculate multi-body contributions to the gradient.
8622 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8623 cd   & k,l,(gacont(m,kk,k),m=1,3)
8624       do m=1,3
8625         gx(m) =ekl*gacont(m,jj,i)
8626         gx1(m)=eij*gacont(m,kk,k)
8627         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8628         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8629         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8630         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8631       enddo
8632       do m=i,j-1
8633         do ll=1,3
8634           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8635         enddo
8636       enddo
8637       do m=k,l-1
8638         do ll=1,3
8639           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8640         enddo
8641       enddo
8642       esccorr=-eij*ekl
8643       return
8644       end
8645 c------------------------------------------------------------------------------
8646       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8647 C This subroutine calculates multi-body contributions to hydrogen-bonding
8648       implicit real*8 (a-h,o-z)
8649       include 'DIMENSIONS'
8650       include 'COMMON.IOUNITS'
8651 #ifdef MPI
8652       include "mpif.h"
8653       parameter (max_cont=maxconts)
8654       parameter (max_dim=26)
8655       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8656       double precision zapas(max_dim,maxconts,max_fg_procs),
8657      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8658       common /przechowalnia/ zapas
8659       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8660      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8661 #endif
8662       include 'COMMON.SETUP'
8663       include 'COMMON.FFIELD'
8664       include 'COMMON.DERIV'
8665       include 'COMMON.INTERACT'
8666       include 'COMMON.CONTACTS'
8667       include 'COMMON.CONTMAT'
8668       include 'COMMON.CORRMAT'
8669       include 'COMMON.CONTROL'
8670       include 'COMMON.LOCAL'
8671       double precision gx(3),gx1(3),time00
8672       logical lprn,ldone
8673
8674 C Set lprn=.true. for debugging
8675       lprn=.false.
8676 #ifdef MPI
8677       n_corr=0
8678       n_corr1=0
8679       if (nfgtasks.le.1) goto 30
8680       if (lprn) then
8681         write (iout,'(a)') 'Contact function values before RECEIVE:'
8682         do i=nnt,nct-2
8683           write (iout,'(2i3,50(1x,i2,f5.2))')
8684      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8685      &    j=1,num_cont_hb(i))
8686         enddo
8687         call flush(iout)
8688       endif
8689       do i=1,ntask_cont_from
8690         ncont_recv(i)=0
8691       enddo
8692       do i=1,ntask_cont_to
8693         ncont_sent(i)=0
8694       enddo
8695 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8696 c     & ntask_cont_to
8697 C Make the list of contacts to send to send to other procesors
8698 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8699 c      call flush(iout)
8700       do i=iturn3_start,iturn3_end
8701 c        write (iout,*) "make contact list turn3",i," num_cont",
8702 c     &    num_cont_hb(i)
8703         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8704       enddo
8705       do i=iturn4_start,iturn4_end
8706 c        write (iout,*) "make contact list turn4",i," num_cont",
8707 c     &   num_cont_hb(i)
8708         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8709       enddo
8710       do ii=1,nat_sent
8711         i=iat_sent(ii)
8712 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8713 c     &    num_cont_hb(i)
8714         do j=1,num_cont_hb(i)
8715         do k=1,4
8716           jjc=jcont_hb(j,i)
8717           iproc=iint_sent_local(k,jjc,ii)
8718 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8719           if (iproc.gt.0) then
8720             ncont_sent(iproc)=ncont_sent(iproc)+1
8721             nn=ncont_sent(iproc)
8722             zapas(1,nn,iproc)=i
8723             zapas(2,nn,iproc)=jjc
8724             zapas(3,nn,iproc)=facont_hb(j,i)
8725             zapas(4,nn,iproc)=ees0p(j,i)
8726             zapas(5,nn,iproc)=ees0m(j,i)
8727             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8728             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8729             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8730             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8731             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8732             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8733             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8734             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8735             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8736             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8737             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8738             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8739             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8740             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8741             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8742             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8743             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8744             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8745             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8746             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8747             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8748           endif
8749         enddo
8750         enddo
8751       enddo
8752       if (lprn) then
8753       write (iout,*)
8754      &  "Numbers of contacts to be sent to other processors",
8755      &  (ncont_sent(i),i=1,ntask_cont_to)
8756       write (iout,*) "Contacts sent"
8757       do ii=1,ntask_cont_to
8758         nn=ncont_sent(ii)
8759         iproc=itask_cont_to(ii)
8760         write (iout,*) nn," contacts to processor",iproc,
8761      &   " of CONT_TO_COMM group"
8762         do i=1,nn
8763           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8764         enddo
8765       enddo
8766       call flush(iout)
8767       endif
8768       CorrelType=477
8769       CorrelID=fg_rank+1
8770       CorrelType1=478
8771       CorrelID1=nfgtasks+fg_rank+1
8772       ireq=0
8773 C Receive the numbers of needed contacts from other processors
8774       do ii=1,ntask_cont_from
8775         iproc=itask_cont_from(ii)
8776         ireq=ireq+1
8777         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8778      &    FG_COMM,req(ireq),IERR)
8779       enddo
8780 c      write (iout,*) "IRECV ended"
8781 c      call flush(iout)
8782 C Send the number of contacts needed by other processors
8783       do ii=1,ntask_cont_to
8784         iproc=itask_cont_to(ii)
8785         ireq=ireq+1
8786         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8787      &    FG_COMM,req(ireq),IERR)
8788       enddo
8789 c      write (iout,*) "ISEND ended"
8790 c      write (iout,*) "number of requests (nn)",ireq
8791 c      call flush(iout)
8792       if (ireq.gt.0)
8793      &  call MPI_Waitall(ireq,req,status_array,ierr)
8794 c      write (iout,*)
8795 c     &  "Numbers of contacts to be received from other processors",
8796 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8797 c      call flush(iout)
8798 C Receive contacts
8799       ireq=0
8800       do ii=1,ntask_cont_from
8801         iproc=itask_cont_from(ii)
8802         nn=ncont_recv(ii)
8803 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8804 c     &   " of CONT_TO_COMM group"
8805 c        call flush(iout)
8806         if (nn.gt.0) then
8807           ireq=ireq+1
8808           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8809      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8810 c          write (iout,*) "ireq,req",ireq,req(ireq)
8811         endif
8812       enddo
8813 C Send the contacts to processors that need them
8814       do ii=1,ntask_cont_to
8815         iproc=itask_cont_to(ii)
8816         nn=ncont_sent(ii)
8817 c        write (iout,*) nn," contacts to processor",iproc,
8818 c     &   " of CONT_TO_COMM group"
8819         if (nn.gt.0) then
8820           ireq=ireq+1
8821           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8822      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8823 c          write (iout,*) "ireq,req",ireq,req(ireq)
8824 c          do i=1,nn
8825 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8826 c          enddo
8827         endif
8828       enddo
8829 c      write (iout,*) "number of requests (contacts)",ireq
8830 c      write (iout,*) "req",(req(i),i=1,4)
8831 c      call flush(iout)
8832       if (ireq.gt.0)
8833      & call MPI_Waitall(ireq,req,status_array,ierr)
8834       do iii=1,ntask_cont_from
8835         iproc=itask_cont_from(iii)
8836         nn=ncont_recv(iii)
8837         if (lprn) then
8838         write (iout,*) "Received",nn," contacts from processor",iproc,
8839      &   " of CONT_FROM_COMM group"
8840         call flush(iout)
8841         do i=1,nn
8842           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8843         enddo
8844         call flush(iout)
8845         endif
8846         do i=1,nn
8847           ii=zapas_recv(1,i,iii)
8848 c Flag the received contacts to prevent double-counting
8849           jj=-zapas_recv(2,i,iii)
8850 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8851 c          call flush(iout)
8852           nnn=num_cont_hb(ii)+1
8853           num_cont_hb(ii)=nnn
8854           jcont_hb(nnn,ii)=jj
8855           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8856           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8857           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8858           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8859           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8860           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8861           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8862           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8863           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8864           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8865           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8866           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8867           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8868           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8869           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8870           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8871           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8872           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8873           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8874           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8875           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8876           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8877           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8878           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8879         enddo
8880       enddo
8881       if (lprn) then
8882         write (iout,'(a)') 'Contact function values after receive:'
8883         do i=nnt,nct-2
8884           write (iout,'(2i3,50(1x,i3,f5.2))')
8885      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8886      &    j=1,num_cont_hb(i))
8887         enddo
8888         call flush(iout)
8889       endif
8890    30 continue
8891 #endif
8892       if (lprn) then
8893         write (iout,'(a)') 'Contact function values:'
8894         do i=nnt,nct-2
8895           write (iout,'(2i3,50(1x,i3,f5.2))')
8896      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8897      &    j=1,num_cont_hb(i))
8898         enddo
8899         call flush(iout)
8900       endif
8901       ecorr=0.0D0
8902 C Remove the loop below after debugging !!!
8903       do i=nnt,nct
8904         do j=1,3
8905           gradcorr(j,i)=0.0D0
8906           gradxorr(j,i)=0.0D0
8907         enddo
8908       enddo
8909 C Calculate the local-electrostatic correlation terms
8910       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8911         i1=i+1
8912         num_conti=num_cont_hb(i)
8913         num_conti1=num_cont_hb(i+1)
8914         do jj=1,num_conti
8915           j=jcont_hb(jj,i)
8916           jp=iabs(j)
8917           do kk=1,num_conti1
8918             j1=jcont_hb(kk,i1)
8919             jp1=iabs(j1)
8920 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8921 c     &         ' jj=',jj,' kk=',kk
8922 c            call flush(iout)
8923             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8924      &          .or. j.lt.0 .and. j1.gt.0) .and.
8925      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8926 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8927 C The system gains extra energy.
8928               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8929               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8930      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8931               n_corr=n_corr+1
8932             else if (j1.eq.j) then
8933 C Contacts I-J and I-(J+1) occur simultaneously.
8934 C The system loses extra energy.
8935 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8936             endif
8937           enddo ! kk
8938           do kk=1,num_conti
8939             j1=jcont_hb(kk,i)
8940 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8941 c    &         ' jj=',jj,' kk=',kk
8942             if (j1.eq.j+1) then
8943 C Contacts I-J and (I+1)-J occur simultaneously.
8944 C The system loses extra energy.
8945 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8946             endif ! j1==j+1
8947           enddo ! kk
8948         enddo ! jj
8949       enddo ! i
8950       return
8951       end
8952 c------------------------------------------------------------------------------
8953       subroutine add_hb_contact(ii,jj,itask)
8954       implicit real*8 (a-h,o-z)
8955       include "DIMENSIONS"
8956       include "COMMON.IOUNITS"
8957       integer max_cont
8958       integer max_dim
8959       parameter (max_cont=maxconts)
8960       parameter (max_dim=26)
8961       include "COMMON.CONTACTS"
8962       include 'COMMON.CONTMAT'
8963       include 'COMMON.CORRMAT'
8964       double precision zapas(max_dim,maxconts,max_fg_procs),
8965      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8966       common /przechowalnia/ zapas
8967       integer i,j,ii,jj,iproc,itask(4),nn
8968 c      write (iout,*) "itask",itask
8969       do i=1,2
8970         iproc=itask(i)
8971         if (iproc.gt.0) then
8972           do j=1,num_cont_hb(ii)
8973             jjc=jcont_hb(j,ii)
8974 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8975             if (jjc.eq.jj) then
8976               ncont_sent(iproc)=ncont_sent(iproc)+1
8977               nn=ncont_sent(iproc)
8978               zapas(1,nn,iproc)=ii
8979               zapas(2,nn,iproc)=jjc
8980               zapas(3,nn,iproc)=facont_hb(j,ii)
8981               zapas(4,nn,iproc)=ees0p(j,ii)
8982               zapas(5,nn,iproc)=ees0m(j,ii)
8983               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8984               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8985               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8986               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8987               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8988               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8989               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8990               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8991               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8992               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8993               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8994               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8995               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8996               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8997               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8998               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8999               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9000               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9001               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9002               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9003               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9004               exit
9005             endif
9006           enddo
9007         endif
9008       enddo
9009       return
9010       end
9011 c------------------------------------------------------------------------------
9012       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9013      &  n_corr1)
9014 C This subroutine calculates multi-body contributions to hydrogen-bonding
9015       implicit real*8 (a-h,o-z)
9016       include 'DIMENSIONS'
9017       include 'COMMON.IOUNITS'
9018 #ifdef MPI
9019       include "mpif.h"
9020       parameter (max_cont=maxconts)
9021       parameter (max_dim=70)
9022       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9023       double precision zapas(max_dim,maxconts,max_fg_procs),
9024      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9025       common /przechowalnia/ zapas
9026       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9027      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9028 #endif
9029       include 'COMMON.SETUP'
9030       include 'COMMON.FFIELD'
9031       include 'COMMON.DERIV'
9032       include 'COMMON.LOCAL'
9033       include 'COMMON.INTERACT'
9034       include 'COMMON.CONTACTS'
9035       include 'COMMON.CONTMAT'
9036       include 'COMMON.CORRMAT'
9037       include 'COMMON.CHAIN'
9038       include 'COMMON.CONTROL'
9039       include 'COMMON.SHIELD'
9040       double precision gx(3),gx1(3)
9041       integer num_cont_hb_old(maxres)
9042       logical lprn,ldone
9043       double precision eello4,eello5,eelo6,eello_turn6
9044       external eello4,eello5,eello6,eello_turn6
9045 C Set lprn=.true. for debugging
9046       lprn=.false.
9047       eturn6=0.0d0
9048 #ifdef MPI
9049       do i=1,nres
9050         num_cont_hb_old(i)=num_cont_hb(i)
9051       enddo
9052       n_corr=0
9053       n_corr1=0
9054       if (nfgtasks.le.1) goto 30
9055       if (lprn) then
9056         write (iout,'(a)') 'Contact function values before RECEIVE:'
9057         do i=nnt,nct-2
9058           write (iout,'(2i3,50(1x,i2,f5.2))')
9059      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9060      &    j=1,num_cont_hb(i))
9061         enddo
9062       endif
9063       do i=1,ntask_cont_from
9064         ncont_recv(i)=0
9065       enddo
9066       do i=1,ntask_cont_to
9067         ncont_sent(i)=0
9068       enddo
9069 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9070 c     & ntask_cont_to
9071 C Make the list of contacts to send to send to other procesors
9072       do i=iturn3_start,iturn3_end
9073 c        write (iout,*) "make contact list turn3",i," num_cont",
9074 c     &    num_cont_hb(i)
9075         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9076       enddo
9077       do i=iturn4_start,iturn4_end
9078 c        write (iout,*) "make contact list turn4",i," num_cont",
9079 c     &   num_cont_hb(i)
9080         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9081       enddo
9082       do ii=1,nat_sent
9083         i=iat_sent(ii)
9084 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9085 c     &    num_cont_hb(i)
9086         do j=1,num_cont_hb(i)
9087         do k=1,4
9088           jjc=jcont_hb(j,i)
9089           iproc=iint_sent_local(k,jjc,ii)
9090 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9091           if (iproc.ne.0) then
9092             ncont_sent(iproc)=ncont_sent(iproc)+1
9093             nn=ncont_sent(iproc)
9094             zapas(1,nn,iproc)=i
9095             zapas(2,nn,iproc)=jjc
9096             zapas(3,nn,iproc)=d_cont(j,i)
9097             ind=3
9098             do kk=1,3
9099               ind=ind+1
9100               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9101             enddo
9102             do kk=1,2
9103               do ll=1,2
9104                 ind=ind+1
9105                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9106               enddo
9107             enddo
9108             do jj=1,5
9109               do kk=1,3
9110                 do ll=1,2
9111                   do mm=1,2
9112                     ind=ind+1
9113                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9114                   enddo
9115                 enddo
9116               enddo
9117             enddo
9118           endif
9119         enddo
9120         enddo
9121       enddo
9122       if (lprn) then
9123       write (iout,*)
9124      &  "Numbers of contacts to be sent to other processors",
9125      &  (ncont_sent(i),i=1,ntask_cont_to)
9126       write (iout,*) "Contacts sent"
9127       do ii=1,ntask_cont_to
9128         nn=ncont_sent(ii)
9129         iproc=itask_cont_to(ii)
9130         write (iout,*) nn," contacts to processor",iproc,
9131      &   " of CONT_TO_COMM group"
9132         do i=1,nn
9133           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9134         enddo
9135       enddo
9136       call flush(iout)
9137       endif
9138       CorrelType=477
9139       CorrelID=fg_rank+1
9140       CorrelType1=478
9141       CorrelID1=nfgtasks+fg_rank+1
9142       ireq=0
9143 C Receive the numbers of needed contacts from other processors
9144       do ii=1,ntask_cont_from
9145         iproc=itask_cont_from(ii)
9146         ireq=ireq+1
9147         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9148      &    FG_COMM,req(ireq),IERR)
9149       enddo
9150 c      write (iout,*) "IRECV ended"
9151 c      call flush(iout)
9152 C Send the number of contacts needed by other processors
9153       do ii=1,ntask_cont_to
9154         iproc=itask_cont_to(ii)
9155         ireq=ireq+1
9156         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9157      &    FG_COMM,req(ireq),IERR)
9158       enddo
9159 c      write (iout,*) "ISEND ended"
9160 c      write (iout,*) "number of requests (nn)",ireq
9161 c      call flush(iout)
9162       if (ireq.gt.0)
9163      &  call MPI_Waitall(ireq,req,status_array,ierr)
9164 c      write (iout,*)
9165 c     &  "Numbers of contacts to be received from other processors",
9166 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9167 c      call flush(iout)
9168 C Receive contacts
9169       ireq=0
9170       do ii=1,ntask_cont_from
9171         iproc=itask_cont_from(ii)
9172         nn=ncont_recv(ii)
9173 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9174 c     &   " of CONT_TO_COMM group"
9175 c        call flush(iout)
9176         if (nn.gt.0) then
9177           ireq=ireq+1
9178           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9179      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9180 c          write (iout,*) "ireq,req",ireq,req(ireq)
9181         endif
9182       enddo
9183 C Send the contacts to processors that need them
9184       do ii=1,ntask_cont_to
9185         iproc=itask_cont_to(ii)
9186         nn=ncont_sent(ii)
9187 c        write (iout,*) nn," contacts to processor",iproc,
9188 c     &   " of CONT_TO_COMM group"
9189         if (nn.gt.0) then
9190           ireq=ireq+1
9191           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9192      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9193 c          write (iout,*) "ireq,req",ireq,req(ireq)
9194 c          do i=1,nn
9195 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9196 c          enddo
9197         endif
9198       enddo
9199 c      write (iout,*) "number of requests (contacts)",ireq
9200 c      write (iout,*) "req",(req(i),i=1,4)
9201 c      call flush(iout)
9202       if (ireq.gt.0)
9203      & call MPI_Waitall(ireq,req,status_array,ierr)
9204       do iii=1,ntask_cont_from
9205         iproc=itask_cont_from(iii)
9206         nn=ncont_recv(iii)
9207         if (lprn) then
9208         write (iout,*) "Received",nn," contacts from processor",iproc,
9209      &   " of CONT_FROM_COMM group"
9210         call flush(iout)
9211         do i=1,nn
9212           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9213         enddo
9214         call flush(iout)
9215         endif
9216         do i=1,nn
9217           ii=zapas_recv(1,i,iii)
9218 c Flag the received contacts to prevent double-counting
9219           jj=-zapas_recv(2,i,iii)
9220 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9221 c          call flush(iout)
9222           nnn=num_cont_hb(ii)+1
9223           num_cont_hb(ii)=nnn
9224           jcont_hb(nnn,ii)=jj
9225           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9226           ind=3
9227           do kk=1,3
9228             ind=ind+1
9229             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9230           enddo
9231           do kk=1,2
9232             do ll=1,2
9233               ind=ind+1
9234               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9235             enddo
9236           enddo
9237           do jj=1,5
9238             do kk=1,3
9239               do ll=1,2
9240                 do mm=1,2
9241                   ind=ind+1
9242                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9243                 enddo
9244               enddo
9245             enddo
9246           enddo
9247         enddo
9248       enddo
9249       if (lprn) then
9250         write (iout,'(a)') 'Contact function values after receive:'
9251         do i=nnt,nct-2
9252           write (iout,'(2i3,50(1x,i3,5f6.3))')
9253      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9254      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9255         enddo
9256         call flush(iout)
9257       endif
9258    30 continue
9259 #endif
9260       if (lprn) then
9261         write (iout,'(a)') 'Contact function values:'
9262         do i=nnt,nct-2
9263           write (iout,'(2i3,50(1x,i2,5f6.3))')
9264      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9265      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9266         enddo
9267       endif
9268       ecorr=0.0D0
9269       ecorr5=0.0d0
9270       ecorr6=0.0d0
9271 C Remove the loop below after debugging !!!
9272       do i=nnt,nct
9273         do j=1,3
9274           gradcorr(j,i)=0.0D0
9275           gradxorr(j,i)=0.0D0
9276         enddo
9277       enddo
9278 C Calculate the dipole-dipole interaction energies
9279       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9280       do i=iatel_s,iatel_e+1
9281         num_conti=num_cont_hb(i)
9282         do jj=1,num_conti
9283           j=jcont_hb(jj,i)
9284 #ifdef MOMENT
9285           call dipole(i,j,jj)
9286 #endif
9287         enddo
9288       enddo
9289       endif
9290 C Calculate the local-electrostatic correlation terms
9291 c                write (iout,*) "gradcorr5 in eello5 before loop"
9292 c                do iii=1,nres
9293 c                  write (iout,'(i5,3f10.5)')
9294 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9295 c                enddo
9296       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9297 c        write (iout,*) "corr loop i",i
9298         i1=i+1
9299         num_conti=num_cont_hb(i)
9300         num_conti1=num_cont_hb(i+1)
9301         do jj=1,num_conti
9302           j=jcont_hb(jj,i)
9303           jp=iabs(j)
9304           do kk=1,num_conti1
9305             j1=jcont_hb(kk,i1)
9306             jp1=iabs(j1)
9307 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9308 c     &         ' jj=',jj,' kk=',kk
9309 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9310             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9311      &          .or. j.lt.0 .and. j1.gt.0) .and.
9312      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9313 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9314 C The system gains extra energy.
9315               n_corr=n_corr+1
9316               sqd1=dsqrt(d_cont(jj,i))
9317               sqd2=dsqrt(d_cont(kk,i1))
9318               sred_geom = sqd1*sqd2
9319               IF (sred_geom.lt.cutoff_corr) THEN
9320                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9321      &            ekont,fprimcont)
9322 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9323 cd     &         ' jj=',jj,' kk=',kk
9324                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9325                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9326                 do l=1,3
9327                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9328                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9329                 enddo
9330                 n_corr1=n_corr1+1
9331 cd               write (iout,*) 'sred_geom=',sred_geom,
9332 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9333 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9334 cd               write (iout,*) "g_contij",g_contij
9335 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9336 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9337                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9338                 if (wcorr4.gt.0.0d0)
9339      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9340 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9341                   if (energy_dec.and.wcorr4.gt.0.0d0)
9342      1                 write (iout,'(a6,4i5,0pf7.3)')
9343      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9344 c                write (iout,*) "gradcorr5 before eello5"
9345 c                do iii=1,nres
9346 c                  write (iout,'(i5,3f10.5)')
9347 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9348 c                enddo
9349                 if (wcorr5.gt.0.0d0)
9350      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9351 c                write (iout,*) "gradcorr5 after eello5"
9352 c                do iii=1,nres
9353 c                  write (iout,'(i5,3f10.5)')
9354 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9355 c                enddo
9356                   if (energy_dec.and.wcorr5.gt.0.0d0)
9357      1                 write (iout,'(a6,4i5,0pf7.3)')
9358      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9359 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9360 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9361                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9362      &               .or. wturn6.eq.0.0d0))then
9363 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9364                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9365                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9366      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9367 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9368 cd     &            'ecorr6=',ecorr6
9369 cd                write (iout,'(4e15.5)') sred_geom,
9370 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9371 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9372 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9373                 else if (wturn6.gt.0.0d0
9374      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9375 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9376                   eturn6=eturn6+eello_turn6(i,jj,kk)
9377                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9378      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9379 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9380                 endif
9381               ENDIF
9382 1111          continue
9383             endif
9384           enddo ! kk
9385         enddo ! jj
9386       enddo ! i
9387       do i=1,nres
9388         num_cont_hb(i)=num_cont_hb_old(i)
9389       enddo
9390 c                write (iout,*) "gradcorr5 in eello5"
9391 c                do iii=1,nres
9392 c                  write (iout,'(i5,3f10.5)')
9393 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9394 c                enddo
9395       return
9396       end
9397 c------------------------------------------------------------------------------
9398       subroutine add_hb_contact_eello(ii,jj,itask)
9399       implicit real*8 (a-h,o-z)
9400       include "DIMENSIONS"
9401       include "COMMON.IOUNITS"
9402       integer max_cont
9403       integer max_dim
9404       parameter (max_cont=maxconts)
9405       parameter (max_dim=70)
9406       include "COMMON.CONTACTS"
9407       include 'COMMON.CONTMAT'
9408       include 'COMMON.CORRMAT'
9409       double precision zapas(max_dim,maxconts,max_fg_procs),
9410      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9411       common /przechowalnia/ zapas
9412       integer i,j,ii,jj,iproc,itask(4),nn
9413 c      write (iout,*) "itask",itask
9414       do i=1,2
9415         iproc=itask(i)
9416         if (iproc.gt.0) then
9417           do j=1,num_cont_hb(ii)
9418             jjc=jcont_hb(j,ii)
9419 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9420             if (jjc.eq.jj) then
9421               ncont_sent(iproc)=ncont_sent(iproc)+1
9422               nn=ncont_sent(iproc)
9423               zapas(1,nn,iproc)=ii
9424               zapas(2,nn,iproc)=jjc
9425               zapas(3,nn,iproc)=d_cont(j,ii)
9426               ind=3
9427               do kk=1,3
9428                 ind=ind+1
9429                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9430               enddo
9431               do kk=1,2
9432                 do ll=1,2
9433                   ind=ind+1
9434                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9435                 enddo
9436               enddo
9437               do jj=1,5
9438                 do kk=1,3
9439                   do ll=1,2
9440                     do mm=1,2
9441                       ind=ind+1
9442                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9443                     enddo
9444                   enddo
9445                 enddo
9446               enddo
9447               exit
9448             endif
9449           enddo
9450         endif
9451       enddo
9452       return
9453       end
9454 c------------------------------------------------------------------------------
9455       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9456       implicit real*8 (a-h,o-z)
9457       include 'DIMENSIONS'
9458       include 'COMMON.IOUNITS'
9459       include 'COMMON.DERIV'
9460       include 'COMMON.INTERACT'
9461       include 'COMMON.CONTACTS'
9462       include 'COMMON.CONTMAT'
9463       include 'COMMON.CORRMAT'
9464       include 'COMMON.SHIELD'
9465       include 'COMMON.CONTROL'
9466       double precision gx(3),gx1(3)
9467       logical lprn
9468       lprn=.false.
9469 C      print *,"wchodze",fac_shield(i),shield_mode
9470       eij=facont_hb(jj,i)
9471       ekl=facont_hb(kk,k)
9472       ees0pij=ees0p(jj,i)
9473       ees0pkl=ees0p(kk,k)
9474       ees0mij=ees0m(jj,i)
9475       ees0mkl=ees0m(kk,k)
9476       ekont=eij*ekl
9477       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9478 C*
9479 C     & fac_shield(i)**2*fac_shield(j)**2
9480 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9481 C Following 4 lines for diagnostics.
9482 cd    ees0pkl=0.0D0
9483 cd    ees0pij=1.0D0
9484 cd    ees0mkl=0.0D0
9485 cd    ees0mij=1.0D0
9486 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9487 c     & 'Contacts ',i,j,
9488 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9489 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9490 c     & 'gradcorr_long'
9491 C Calculate the multi-body contribution to energy.
9492 C      ecorr=ecorr+ekont*ees
9493 C Calculate multi-body contributions to the gradient.
9494       coeffpees0pij=coeffp*ees0pij
9495       coeffmees0mij=coeffm*ees0mij
9496       coeffpees0pkl=coeffp*ees0pkl
9497       coeffmees0mkl=coeffm*ees0mkl
9498       do ll=1,3
9499 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9500         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9501      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9502      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9503         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9504      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9505      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9506 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9507         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9508      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9509      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9510         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9511      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9512      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9513         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9514      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9515      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9516         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9517         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9518         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9519      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9520      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9521         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9522         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9523 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9524       enddo
9525 c      write (iout,*)
9526 cgrad      do m=i+1,j-1
9527 cgrad        do ll=1,3
9528 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9529 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9530 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9531 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9532 cgrad        enddo
9533 cgrad      enddo
9534 cgrad      do m=k+1,l-1
9535 cgrad        do ll=1,3
9536 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9537 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9538 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9539 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9540 cgrad        enddo
9541 cgrad      enddo
9542 c      write (iout,*) "ehbcorr",ekont*ees
9543 C      print *,ekont,ees,i,k
9544       ehbcorr=ekont*ees
9545 C now gradient over shielding
9546 C      return
9547       if (shield_mode.gt.0) then
9548        j=ees0plist(jj,i)
9549        l=ees0plist(kk,k)
9550 C        print *,i,j,fac_shield(i),fac_shield(j),
9551 C     &fac_shield(k),fac_shield(l)
9552         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9553      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9554           do ilist=1,ishield_list(i)
9555            iresshield=shield_list(ilist,i)
9556            do m=1,3
9557            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9558 C     &      *2.0
9559            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9560      &              rlocshield
9561      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9562             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9563      &+rlocshield
9564            enddo
9565           enddo
9566           do ilist=1,ishield_list(j)
9567            iresshield=shield_list(ilist,j)
9568            do m=1,3
9569            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9570 C     &     *2.0
9571            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9572      &              rlocshield
9573      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9574            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9575      &     +rlocshield
9576            enddo
9577           enddo
9578
9579           do ilist=1,ishield_list(k)
9580            iresshield=shield_list(ilist,k)
9581            do m=1,3
9582            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9583 C     &     *2.0
9584            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9585      &              rlocshield
9586      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9587            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9588      &     +rlocshield
9589            enddo
9590           enddo
9591           do ilist=1,ishield_list(l)
9592            iresshield=shield_list(ilist,l)
9593            do m=1,3
9594            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9595 C     &     *2.0
9596            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9597      &              rlocshield
9598      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9599            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9600      &     +rlocshield
9601            enddo
9602           enddo
9603 C          print *,gshieldx(m,iresshield)
9604           do m=1,3
9605             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9606      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9607             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9608      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9609             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9610      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9611             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9612      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9613
9614             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9615      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9616             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9617      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9618             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9619      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9620             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9621      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9622
9623            enddo
9624       endif
9625       endif
9626       return
9627       end
9628 #ifdef MOMENT
9629 C---------------------------------------------------------------------------
9630       subroutine dipole(i,j,jj)
9631       implicit real*8 (a-h,o-z)
9632       include 'DIMENSIONS'
9633       include 'COMMON.IOUNITS'
9634       include 'COMMON.CHAIN'
9635       include 'COMMON.FFIELD'
9636       include 'COMMON.DERIV'
9637       include 'COMMON.INTERACT'
9638       include 'COMMON.CONTACTS'
9639       include 'COMMON.CONTMAT'
9640       include 'COMMON.CORRMAT'
9641       include 'COMMON.TORSION'
9642       include 'COMMON.VAR'
9643       include 'COMMON.GEO'
9644       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9645      &  auxmat(2,2)
9646       iti1 = itortyp(itype(i+1))
9647       if (j.lt.nres-1) then
9648         itj1 = itype2loc(itype(j+1))
9649       else
9650         itj1=nloctyp
9651       endif
9652       do iii=1,2
9653         dipi(iii,1)=Ub2(iii,i)
9654         dipderi(iii)=Ub2der(iii,i)
9655         dipi(iii,2)=b1(iii,i+1)
9656         dipj(iii,1)=Ub2(iii,j)
9657         dipderj(iii)=Ub2der(iii,j)
9658         dipj(iii,2)=b1(iii,j+1)
9659       enddo
9660       kkk=0
9661       do iii=1,2
9662         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9663         do jjj=1,2
9664           kkk=kkk+1
9665           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9666         enddo
9667       enddo
9668       do kkk=1,5
9669         do lll=1,3
9670           mmm=0
9671           do iii=1,2
9672             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9673      &        auxvec(1))
9674             do jjj=1,2
9675               mmm=mmm+1
9676               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9677             enddo
9678           enddo
9679         enddo
9680       enddo
9681       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9682       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9683       do iii=1,2
9684         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9685       enddo
9686       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9687       do iii=1,2
9688         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9689       enddo
9690       return
9691       end
9692 #endif
9693 C---------------------------------------------------------------------------
9694       subroutine calc_eello(i,j,k,l,jj,kk)
9695 C
9696 C This subroutine computes matrices and vectors needed to calculate
9697 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9698 C
9699       implicit real*8 (a-h,o-z)
9700       include 'DIMENSIONS'
9701       include 'COMMON.IOUNITS'
9702       include 'COMMON.CHAIN'
9703       include 'COMMON.DERIV'
9704       include 'COMMON.INTERACT'
9705       include 'COMMON.CONTACTS'
9706       include 'COMMON.CONTMAT'
9707       include 'COMMON.CORRMAT'
9708       include 'COMMON.TORSION'
9709       include 'COMMON.VAR'
9710       include 'COMMON.GEO'
9711       include 'COMMON.FFIELD'
9712       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9713      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9714       logical lprn
9715       common /kutas/ lprn
9716 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9717 cd     & ' jj=',jj,' kk=',kk
9718 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9719 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9720 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9721       do iii=1,2
9722         do jjj=1,2
9723           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9724           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9725         enddo
9726       enddo
9727       call transpose2(aa1(1,1),aa1t(1,1))
9728       call transpose2(aa2(1,1),aa2t(1,1))
9729       do kkk=1,5
9730         do lll=1,3
9731           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9732      &      aa1tder(1,1,lll,kkk))
9733           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9734      &      aa2tder(1,1,lll,kkk))
9735         enddo
9736       enddo
9737       if (l.eq.j+1) then
9738 C parallel orientation of the two CA-CA-CA frames.
9739         if (i.gt.1) then
9740           iti=itype2loc(itype(i))
9741         else
9742           iti=nloctyp
9743         endif
9744         itk1=itype2loc(itype(k+1))
9745         itj=itype2loc(itype(j))
9746         if (l.lt.nres-1) then
9747           itl1=itype2loc(itype(l+1))
9748         else
9749           itl1=nloctyp
9750         endif
9751 C A1 kernel(j+1) A2T
9752 cd        do iii=1,2
9753 cd          write (iout,'(3f10.5,5x,3f10.5)')
9754 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9755 cd        enddo
9756         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9757      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9758      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9759 C Following matrices are needed only for 6-th order cumulants
9760         IF (wcorr6.gt.0.0d0) THEN
9761         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9762      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9763      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9764         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9765      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9766      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9767      &   ADtEAderx(1,1,1,1,1,1))
9768         lprn=.false.
9769         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9770      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9771      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9772      &   ADtEA1derx(1,1,1,1,1,1))
9773         ENDIF
9774 C End 6-th order cumulants
9775 cd        lprn=.false.
9776 cd        if (lprn) then
9777 cd        write (2,*) 'In calc_eello6'
9778 cd        do iii=1,2
9779 cd          write (2,*) 'iii=',iii
9780 cd          do kkk=1,5
9781 cd            write (2,*) 'kkk=',kkk
9782 cd            do jjj=1,2
9783 cd              write (2,'(3(2f10.5),5x)')
9784 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9785 cd            enddo
9786 cd          enddo
9787 cd        enddo
9788 cd        endif
9789         call transpose2(EUgder(1,1,k),auxmat(1,1))
9790         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9791         call transpose2(EUg(1,1,k),auxmat(1,1))
9792         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9793         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9794 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9795 c    in theta; to be sriten later.
9796 c#ifdef NEWCORR
9797 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9798 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9799 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9800 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9801 c#endif
9802         do iii=1,2
9803           do kkk=1,5
9804             do lll=1,3
9805               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9806      &          EAEAderx(1,1,lll,kkk,iii,1))
9807             enddo
9808           enddo
9809         enddo
9810 C A1T kernel(i+1) A2
9811         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9812      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9813      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9814 C Following matrices are needed only for 6-th order cumulants
9815         IF (wcorr6.gt.0.0d0) THEN
9816         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9817      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9818      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9819         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9820      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9821      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9822      &   ADtEAderx(1,1,1,1,1,2))
9823         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9824      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9825      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9826      &   ADtEA1derx(1,1,1,1,1,2))
9827         ENDIF
9828 C End 6-th order cumulants
9829         call transpose2(EUgder(1,1,l),auxmat(1,1))
9830         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9831         call transpose2(EUg(1,1,l),auxmat(1,1))
9832         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9833         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9834         do iii=1,2
9835           do kkk=1,5
9836             do lll=1,3
9837               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9838      &          EAEAderx(1,1,lll,kkk,iii,2))
9839             enddo
9840           enddo
9841         enddo
9842 C AEAb1 and AEAb2
9843 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9844 C They are needed only when the fifth- or the sixth-order cumulants are
9845 C indluded.
9846         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9847         call transpose2(AEA(1,1,1),auxmat(1,1))
9848         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9849         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9850         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9851         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9852         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9853         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9854         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9855         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9856         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9857         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9858         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9859         call transpose2(AEA(1,1,2),auxmat(1,1))
9860         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9861         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9862         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9863         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9864         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9865         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9866         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9867         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9868         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9869         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9870         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9871 C Calculate the Cartesian derivatives of the vectors.
9872         do iii=1,2
9873           do kkk=1,5
9874             do lll=1,3
9875               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9876               call matvec2(auxmat(1,1),b1(1,i),
9877      &          AEAb1derx(1,lll,kkk,iii,1,1))
9878               call matvec2(auxmat(1,1),Ub2(1,i),
9879      &          AEAb2derx(1,lll,kkk,iii,1,1))
9880               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9881      &          AEAb1derx(1,lll,kkk,iii,2,1))
9882               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9883      &          AEAb2derx(1,lll,kkk,iii,2,1))
9884               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9885               call matvec2(auxmat(1,1),b1(1,j),
9886      &          AEAb1derx(1,lll,kkk,iii,1,2))
9887               call matvec2(auxmat(1,1),Ub2(1,j),
9888      &          AEAb2derx(1,lll,kkk,iii,1,2))
9889               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9890      &          AEAb1derx(1,lll,kkk,iii,2,2))
9891               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9892      &          AEAb2derx(1,lll,kkk,iii,2,2))
9893             enddo
9894           enddo
9895         enddo
9896         ENDIF
9897 C End vectors
9898       else
9899 C Antiparallel orientation of the two CA-CA-CA frames.
9900         if (i.gt.1) then
9901           iti=itype2loc(itype(i))
9902         else
9903           iti=nloctyp
9904         endif
9905         itk1=itype2loc(itype(k+1))
9906         itl=itype2loc(itype(l))
9907         itj=itype2loc(itype(j))
9908         if (j.lt.nres-1) then
9909           itj1=itype2loc(itype(j+1))
9910         else
9911           itj1=nloctyp
9912         endif
9913 C A2 kernel(j-1)T A1T
9914         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9915      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9916      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9917 C Following matrices are needed only for 6-th order cumulants
9918         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9919      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9920         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9921      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9922      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9923         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9924      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9925      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9926      &   ADtEAderx(1,1,1,1,1,1))
9927         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9928      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9929      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9930      &   ADtEA1derx(1,1,1,1,1,1))
9931         ENDIF
9932 C End 6-th order cumulants
9933         call transpose2(EUgder(1,1,k),auxmat(1,1))
9934         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9935         call transpose2(EUg(1,1,k),auxmat(1,1))
9936         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9937         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9938         do iii=1,2
9939           do kkk=1,5
9940             do lll=1,3
9941               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9942      &          EAEAderx(1,1,lll,kkk,iii,1))
9943             enddo
9944           enddo
9945         enddo
9946 C A2T kernel(i+1)T A1
9947         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9948      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9949      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9950 C Following matrices are needed only for 6-th order cumulants
9951         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9952      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9953         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9954      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9955      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9956         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9957      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9958      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9959      &   ADtEAderx(1,1,1,1,1,2))
9960         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9961      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9962      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9963      &   ADtEA1derx(1,1,1,1,1,2))
9964         ENDIF
9965 C End 6-th order cumulants
9966         call transpose2(EUgder(1,1,j),auxmat(1,1))
9967         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9968         call transpose2(EUg(1,1,j),auxmat(1,1))
9969         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9970         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9971         do iii=1,2
9972           do kkk=1,5
9973             do lll=1,3
9974               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9975      &          EAEAderx(1,1,lll,kkk,iii,2))
9976             enddo
9977           enddo
9978         enddo
9979 C AEAb1 and AEAb2
9980 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9981 C They are needed only when the fifth- or the sixth-order cumulants are
9982 C indluded.
9983         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9984      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9985         call transpose2(AEA(1,1,1),auxmat(1,1))
9986         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9987         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9988         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9989         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9990         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9991         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9992         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9993         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9994         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9995         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9996         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9997         call transpose2(AEA(1,1,2),auxmat(1,1))
9998         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9999         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10000         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10001         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10002         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10003         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10004         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10005         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10006         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10007         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10008         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10009 C Calculate the Cartesian derivatives of the vectors.
10010         do iii=1,2
10011           do kkk=1,5
10012             do lll=1,3
10013               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10014               call matvec2(auxmat(1,1),b1(1,i),
10015      &          AEAb1derx(1,lll,kkk,iii,1,1))
10016               call matvec2(auxmat(1,1),Ub2(1,i),
10017      &          AEAb2derx(1,lll,kkk,iii,1,1))
10018               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10019      &          AEAb1derx(1,lll,kkk,iii,2,1))
10020               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10021      &          AEAb2derx(1,lll,kkk,iii,2,1))
10022               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10023               call matvec2(auxmat(1,1),b1(1,l),
10024      &          AEAb1derx(1,lll,kkk,iii,1,2))
10025               call matvec2(auxmat(1,1),Ub2(1,l),
10026      &          AEAb2derx(1,lll,kkk,iii,1,2))
10027               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10028      &          AEAb1derx(1,lll,kkk,iii,2,2))
10029               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10030      &          AEAb2derx(1,lll,kkk,iii,2,2))
10031             enddo
10032           enddo
10033         enddo
10034         ENDIF
10035 C End vectors
10036       endif
10037       return
10038       end
10039 C---------------------------------------------------------------------------
10040       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10041      &  KK,KKderg,AKA,AKAderg,AKAderx)
10042       implicit none
10043       integer nderg
10044       logical transp
10045       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10046      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10047      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10048       integer iii,kkk,lll
10049       integer jjj,mmm
10050       logical lprn
10051       common /kutas/ lprn
10052       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10053       do iii=1,nderg
10054         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10055      &    AKAderg(1,1,iii))
10056       enddo
10057 cd      if (lprn) write (2,*) 'In kernel'
10058       do kkk=1,5
10059 cd        if (lprn) write (2,*) 'kkk=',kkk
10060         do lll=1,3
10061           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10062      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10063 cd          if (lprn) then
10064 cd            write (2,*) 'lll=',lll
10065 cd            write (2,*) 'iii=1'
10066 cd            do jjj=1,2
10067 cd              write (2,'(3(2f10.5),5x)')
10068 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10069 cd            enddo
10070 cd          endif
10071           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10072      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10073 cd          if (lprn) then
10074 cd            write (2,*) 'lll=',lll
10075 cd            write (2,*) 'iii=2'
10076 cd            do jjj=1,2
10077 cd              write (2,'(3(2f10.5),5x)')
10078 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10079 cd            enddo
10080 cd          endif
10081         enddo
10082       enddo
10083       return
10084       end
10085 C---------------------------------------------------------------------------
10086       double precision function eello4(i,j,k,l,jj,kk)
10087       implicit real*8 (a-h,o-z)
10088       include 'DIMENSIONS'
10089       include 'COMMON.IOUNITS'
10090       include 'COMMON.CHAIN'
10091       include 'COMMON.DERIV'
10092       include 'COMMON.INTERACT'
10093       include 'COMMON.CONTACTS'
10094       include 'COMMON.CONTMAT'
10095       include 'COMMON.CORRMAT'
10096       include 'COMMON.TORSION'
10097       include 'COMMON.VAR'
10098       include 'COMMON.GEO'
10099       double precision pizda(2,2),ggg1(3),ggg2(3)
10100 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10101 cd        eello4=0.0d0
10102 cd        return
10103 cd      endif
10104 cd      print *,'eello4:',i,j,k,l,jj,kk
10105 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10106 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10107 cold      eij=facont_hb(jj,i)
10108 cold      ekl=facont_hb(kk,k)
10109 cold      ekont=eij*ekl
10110       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10111 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10112       gcorr_loc(k-1)=gcorr_loc(k-1)
10113      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10114       if (l.eq.j+1) then
10115         gcorr_loc(l-1)=gcorr_loc(l-1)
10116      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10117 C Al 4/16/16: Derivatives in theta, to be added later.
10118 c#ifdef NEWCORR
10119 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10120 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10121 c#endif
10122       else
10123         gcorr_loc(j-1)=gcorr_loc(j-1)
10124      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10125 c#ifdef NEWCORR
10126 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10127 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10128 c#endif
10129       endif
10130       do iii=1,2
10131         do kkk=1,5
10132           do lll=1,3
10133             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10134      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10135 cd            derx(lll,kkk,iii)=0.0d0
10136           enddo
10137         enddo
10138       enddo
10139 cd      gcorr_loc(l-1)=0.0d0
10140 cd      gcorr_loc(j-1)=0.0d0
10141 cd      gcorr_loc(k-1)=0.0d0
10142 cd      eel4=1.0d0
10143 cd      write (iout,*)'Contacts have occurred for peptide groups',
10144 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10145 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10146       if (j.lt.nres-1) then
10147         j1=j+1
10148         j2=j-1
10149       else
10150         j1=j-1
10151         j2=j-2
10152       endif
10153       if (l.lt.nres-1) then
10154         l1=l+1
10155         l2=l-1
10156       else
10157         l1=l-1
10158         l2=l-2
10159       endif
10160       do ll=1,3
10161 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10162 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10163         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10164         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10165 cgrad        ghalf=0.5d0*ggg1(ll)
10166         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10167         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10168         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10169         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10170         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10171         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10172 cgrad        ghalf=0.5d0*ggg2(ll)
10173         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10174         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10175         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10176         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10177         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10178         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10179       enddo
10180 cgrad      do m=i+1,j-1
10181 cgrad        do ll=1,3
10182 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10183 cgrad        enddo
10184 cgrad      enddo
10185 cgrad      do m=k+1,l-1
10186 cgrad        do ll=1,3
10187 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10188 cgrad        enddo
10189 cgrad      enddo
10190 cgrad      do m=i+2,j2
10191 cgrad        do ll=1,3
10192 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10193 cgrad        enddo
10194 cgrad      enddo
10195 cgrad      do m=k+2,l2
10196 cgrad        do ll=1,3
10197 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10198 cgrad        enddo
10199 cgrad      enddo
10200 cd      do iii=1,nres-3
10201 cd        write (2,*) iii,gcorr_loc(iii)
10202 cd      enddo
10203       eello4=ekont*eel4
10204 cd      write (2,*) 'ekont',ekont
10205 cd      write (iout,*) 'eello4',ekont*eel4
10206       return
10207       end
10208 C---------------------------------------------------------------------------
10209       double precision function eello5(i,j,k,l,jj,kk)
10210       implicit real*8 (a-h,o-z)
10211       include 'DIMENSIONS'
10212       include 'COMMON.IOUNITS'
10213       include 'COMMON.CHAIN'
10214       include 'COMMON.DERIV'
10215       include 'COMMON.INTERACT'
10216       include 'COMMON.CONTACTS'
10217       include 'COMMON.CONTMAT'
10218       include 'COMMON.CORRMAT'
10219       include 'COMMON.TORSION'
10220       include 'COMMON.VAR'
10221       include 'COMMON.GEO'
10222       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10223       double precision ggg1(3),ggg2(3)
10224 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10225 C                                                                              C
10226 C                            Parallel chains                                   C
10227 C                                                                              C
10228 C          o             o                   o             o                   C
10229 C         /l\           / \             \   / \           / \   /              C
10230 C        /   \         /   \             \ /   \         /   \ /               C
10231 C       j| o |l1       | o |              o| o |         | o |o                C
10232 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10233 C      \i/   \         /   \ /             /   \         /   \                 C
10234 C       o    k1             o                                                  C
10235 C         (I)          (II)                (III)          (IV)                 C
10236 C                                                                              C
10237 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10238 C                                                                              C
10239 C                            Antiparallel chains                               C
10240 C                                                                              C
10241 C          o             o                   o             o                   C
10242 C         /j\           / \             \   / \           / \   /              C
10243 C        /   \         /   \             \ /   \         /   \ /               C
10244 C      j1| o |l        | o |              o| o |         | o |o                C
10245 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10246 C      \i/   \         /   \ /             /   \         /   \                 C
10247 C       o     k1            o                                                  C
10248 C         (I)          (II)                (III)          (IV)                 C
10249 C                                                                              C
10250 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10251 C                                                                              C
10252 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10253 C                                                                              C
10254 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10255 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10256 cd        eello5=0.0d0
10257 cd        return
10258 cd      endif
10259 cd      write (iout,*)
10260 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10261 cd     &   ' and',k,l
10262       itk=itype2loc(itype(k))
10263       itl=itype2loc(itype(l))
10264       itj=itype2loc(itype(j))
10265       eello5_1=0.0d0
10266       eello5_2=0.0d0
10267       eello5_3=0.0d0
10268       eello5_4=0.0d0
10269 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10270 cd     &   eel5_3_num,eel5_4_num)
10271       do iii=1,2
10272         do kkk=1,5
10273           do lll=1,3
10274             derx(lll,kkk,iii)=0.0d0
10275           enddo
10276         enddo
10277       enddo
10278 cd      eij=facont_hb(jj,i)
10279 cd      ekl=facont_hb(kk,k)
10280 cd      ekont=eij*ekl
10281 cd      write (iout,*)'Contacts have occurred for peptide groups',
10282 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10283 cd      goto 1111
10284 C Contribution from the graph I.
10285 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10286 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10287       call transpose2(EUg(1,1,k),auxmat(1,1))
10288       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10289       vv(1)=pizda(1,1)-pizda(2,2)
10290       vv(2)=pizda(1,2)+pizda(2,1)
10291       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10292      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10293 C Explicit gradient in virtual-dihedral angles.
10294       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10295      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10296      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10297       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10298       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10299       vv(1)=pizda(1,1)-pizda(2,2)
10300       vv(2)=pizda(1,2)+pizda(2,1)
10301       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10302      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10303      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10304       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10305       vv(1)=pizda(1,1)-pizda(2,2)
10306       vv(2)=pizda(1,2)+pizda(2,1)
10307       if (l.eq.j+1) then
10308         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10309      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10310      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10311       else
10312         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10313      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10314      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10315       endif
10316 C Cartesian gradient
10317       do iii=1,2
10318         do kkk=1,5
10319           do lll=1,3
10320             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10321      &        pizda(1,1))
10322             vv(1)=pizda(1,1)-pizda(2,2)
10323             vv(2)=pizda(1,2)+pizda(2,1)
10324             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10325      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10326      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10327           enddo
10328         enddo
10329       enddo
10330 c      goto 1112
10331 c1111  continue
10332 C Contribution from graph II
10333       call transpose2(EE(1,1,k),auxmat(1,1))
10334       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10335       vv(1)=pizda(1,1)+pizda(2,2)
10336       vv(2)=pizda(2,1)-pizda(1,2)
10337       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10338      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10339 C Explicit gradient in virtual-dihedral angles.
10340       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10341      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10342       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10343       vv(1)=pizda(1,1)+pizda(2,2)
10344       vv(2)=pizda(2,1)-pizda(1,2)
10345       if (l.eq.j+1) then
10346         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10347      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10348      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10349       else
10350         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10351      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10352      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10353       endif
10354 C Cartesian gradient
10355       do iii=1,2
10356         do kkk=1,5
10357           do lll=1,3
10358             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10359      &        pizda(1,1))
10360             vv(1)=pizda(1,1)+pizda(2,2)
10361             vv(2)=pizda(2,1)-pizda(1,2)
10362             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10363      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10364      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10365           enddo
10366         enddo
10367       enddo
10368 cd      goto 1112
10369 cd1111  continue
10370       if (l.eq.j+1) then
10371 cd        goto 1110
10372 C Parallel orientation
10373 C Contribution from graph III
10374         call transpose2(EUg(1,1,l),auxmat(1,1))
10375         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10376         vv(1)=pizda(1,1)-pizda(2,2)
10377         vv(2)=pizda(1,2)+pizda(2,1)
10378         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10379      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10380 C Explicit gradient in virtual-dihedral angles.
10381         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10382      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10383      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10384         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10385         vv(1)=pizda(1,1)-pizda(2,2)
10386         vv(2)=pizda(1,2)+pizda(2,1)
10387         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10388      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10389      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10390         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10391         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10392         vv(1)=pizda(1,1)-pizda(2,2)
10393         vv(2)=pizda(1,2)+pizda(2,1)
10394         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10395      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10396      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10397 C Cartesian gradient
10398         do iii=1,2
10399           do kkk=1,5
10400             do lll=1,3
10401               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10402      &          pizda(1,1))
10403               vv(1)=pizda(1,1)-pizda(2,2)
10404               vv(2)=pizda(1,2)+pizda(2,1)
10405               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10406      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10407      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10408             enddo
10409           enddo
10410         enddo
10411 cd        goto 1112
10412 C Contribution from graph IV
10413 cd1110    continue
10414         call transpose2(EE(1,1,l),auxmat(1,1))
10415         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10416         vv(1)=pizda(1,1)+pizda(2,2)
10417         vv(2)=pizda(2,1)-pizda(1,2)
10418         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10419      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10420 C Explicit gradient in virtual-dihedral angles.
10421         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10422      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10423         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10424         vv(1)=pizda(1,1)+pizda(2,2)
10425         vv(2)=pizda(2,1)-pizda(1,2)
10426         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10427      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10428      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10429 C Cartesian gradient
10430         do iii=1,2
10431           do kkk=1,5
10432             do lll=1,3
10433               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10434      &          pizda(1,1))
10435               vv(1)=pizda(1,1)+pizda(2,2)
10436               vv(2)=pizda(2,1)-pizda(1,2)
10437               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10438      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10439      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10440             enddo
10441           enddo
10442         enddo
10443       else
10444 C Antiparallel orientation
10445 C Contribution from graph III
10446 c        goto 1110
10447         call transpose2(EUg(1,1,j),auxmat(1,1))
10448         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10449         vv(1)=pizda(1,1)-pizda(2,2)
10450         vv(2)=pizda(1,2)+pizda(2,1)
10451         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10452      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10453 C Explicit gradient in virtual-dihedral angles.
10454         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10455      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10456      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10457         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10458         vv(1)=pizda(1,1)-pizda(2,2)
10459         vv(2)=pizda(1,2)+pizda(2,1)
10460         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10461      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10462      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10463         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10464         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10465         vv(1)=pizda(1,1)-pizda(2,2)
10466         vv(2)=pizda(1,2)+pizda(2,1)
10467         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10468      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10469      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10470 C Cartesian gradient
10471         do iii=1,2
10472           do kkk=1,5
10473             do lll=1,3
10474               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10475      &          pizda(1,1))
10476               vv(1)=pizda(1,1)-pizda(2,2)
10477               vv(2)=pizda(1,2)+pizda(2,1)
10478               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10479      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10480      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10481             enddo
10482           enddo
10483         enddo
10484 cd        goto 1112
10485 C Contribution from graph IV
10486 1110    continue
10487         call transpose2(EE(1,1,j),auxmat(1,1))
10488         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10489         vv(1)=pizda(1,1)+pizda(2,2)
10490         vv(2)=pizda(2,1)-pizda(1,2)
10491         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10492      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10493 C Explicit gradient in virtual-dihedral angles.
10494         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10495      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10496         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10497         vv(1)=pizda(1,1)+pizda(2,2)
10498         vv(2)=pizda(2,1)-pizda(1,2)
10499         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10500      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10501      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10502 C Cartesian gradient
10503         do iii=1,2
10504           do kkk=1,5
10505             do lll=1,3
10506               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10507      &          pizda(1,1))
10508               vv(1)=pizda(1,1)+pizda(2,2)
10509               vv(2)=pizda(2,1)-pizda(1,2)
10510               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10511      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10512      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10513             enddo
10514           enddo
10515         enddo
10516       endif
10517 1112  continue
10518       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10519 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10520 cd        write (2,*) 'ijkl',i,j,k,l
10521 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10522 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10523 cd      endif
10524 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10525 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10526 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10527 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10528       if (j.lt.nres-1) then
10529         j1=j+1
10530         j2=j-1
10531       else
10532         j1=j-1
10533         j2=j-2
10534       endif
10535       if (l.lt.nres-1) then
10536         l1=l+1
10537         l2=l-1
10538       else
10539         l1=l-1
10540         l2=l-2
10541       endif
10542 cd      eij=1.0d0
10543 cd      ekl=1.0d0
10544 cd      ekont=1.0d0
10545 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10546 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10547 C        summed up outside the subrouine as for the other subroutines
10548 C        handling long-range interactions. The old code is commented out
10549 C        with "cgrad" to keep track of changes.
10550       do ll=1,3
10551 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10552 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10553         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10554         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10555 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10556 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10557 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10558 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10559 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10560 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10561 c     &   gradcorr5ij,
10562 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10563 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10564 cgrad        ghalf=0.5d0*ggg1(ll)
10565 cd        ghalf=0.0d0
10566         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10567         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10568         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10569         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10570         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10571         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10572 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10573 cgrad        ghalf=0.5d0*ggg2(ll)
10574 cd        ghalf=0.0d0
10575         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10576         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10577         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10578         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10579         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10580         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10581       enddo
10582 cd      goto 1112
10583 cgrad      do m=i+1,j-1
10584 cgrad        do ll=1,3
10585 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10586 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10587 cgrad        enddo
10588 cgrad      enddo
10589 cgrad      do m=k+1,l-1
10590 cgrad        do ll=1,3
10591 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10592 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10593 cgrad        enddo
10594 cgrad      enddo
10595 c1112  continue
10596 cgrad      do m=i+2,j2
10597 cgrad        do ll=1,3
10598 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10599 cgrad        enddo
10600 cgrad      enddo
10601 cgrad      do m=k+2,l2
10602 cgrad        do ll=1,3
10603 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10604 cgrad        enddo
10605 cgrad      enddo
10606 cd      do iii=1,nres-3
10607 cd        write (2,*) iii,g_corr5_loc(iii)
10608 cd      enddo
10609       eello5=ekont*eel5
10610 cd      write (2,*) 'ekont',ekont
10611 cd      write (iout,*) 'eello5',ekont*eel5
10612       return
10613       end
10614 c--------------------------------------------------------------------------
10615       double precision function eello6(i,j,k,l,jj,kk)
10616       implicit real*8 (a-h,o-z)
10617       include 'DIMENSIONS'
10618       include 'COMMON.IOUNITS'
10619       include 'COMMON.CHAIN'
10620       include 'COMMON.DERIV'
10621       include 'COMMON.INTERACT'
10622       include 'COMMON.CONTACTS'
10623       include 'COMMON.CONTMAT'
10624       include 'COMMON.CORRMAT'
10625       include 'COMMON.TORSION'
10626       include 'COMMON.VAR'
10627       include 'COMMON.GEO'
10628       include 'COMMON.FFIELD'
10629       double precision ggg1(3),ggg2(3)
10630 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10631 cd        eello6=0.0d0
10632 cd        return
10633 cd      endif
10634 cd      write (iout,*)
10635 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10636 cd     &   ' and',k,l
10637       eello6_1=0.0d0
10638       eello6_2=0.0d0
10639       eello6_3=0.0d0
10640       eello6_4=0.0d0
10641       eello6_5=0.0d0
10642       eello6_6=0.0d0
10643 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10644 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10645       do iii=1,2
10646         do kkk=1,5
10647           do lll=1,3
10648             derx(lll,kkk,iii)=0.0d0
10649           enddo
10650         enddo
10651       enddo
10652 cd      eij=facont_hb(jj,i)
10653 cd      ekl=facont_hb(kk,k)
10654 cd      ekont=eij*ekl
10655 cd      eij=1.0d0
10656 cd      ekl=1.0d0
10657 cd      ekont=1.0d0
10658       if (l.eq.j+1) then
10659         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10660         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10661         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10662         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10663         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10664         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10665       else
10666         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10667         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10668         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10669         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10670         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10671           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10672         else
10673           eello6_5=0.0d0
10674         endif
10675         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10676       endif
10677 C If turn contributions are considered, they will be handled separately.
10678       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10679 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10680 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10681 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10682 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10683 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10684 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10685 cd      goto 1112
10686       if (j.lt.nres-1) then
10687         j1=j+1
10688         j2=j-1
10689       else
10690         j1=j-1
10691         j2=j-2
10692       endif
10693       if (l.lt.nres-1) then
10694         l1=l+1
10695         l2=l-1
10696       else
10697         l1=l-1
10698         l2=l-2
10699       endif
10700       do ll=1,3
10701 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10702 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10703 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10704 cgrad        ghalf=0.5d0*ggg1(ll)
10705 cd        ghalf=0.0d0
10706         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10707         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10708         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10709         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10710         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10711         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10712         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10713         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10714 cgrad        ghalf=0.5d0*ggg2(ll)
10715 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10716 cd        ghalf=0.0d0
10717         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10718         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10719         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10720         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10721         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10722         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10723       enddo
10724 cd      goto 1112
10725 cgrad      do m=i+1,j-1
10726 cgrad        do ll=1,3
10727 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10728 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10729 cgrad        enddo
10730 cgrad      enddo
10731 cgrad      do m=k+1,l-1
10732 cgrad        do ll=1,3
10733 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10734 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10735 cgrad        enddo
10736 cgrad      enddo
10737 cgrad1112  continue
10738 cgrad      do m=i+2,j2
10739 cgrad        do ll=1,3
10740 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10741 cgrad        enddo
10742 cgrad      enddo
10743 cgrad      do m=k+2,l2
10744 cgrad        do ll=1,3
10745 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10746 cgrad        enddo
10747 cgrad      enddo
10748 cd      do iii=1,nres-3
10749 cd        write (2,*) iii,g_corr6_loc(iii)
10750 cd      enddo
10751       eello6=ekont*eel6
10752 cd      write (2,*) 'ekont',ekont
10753 cd      write (iout,*) 'eello6',ekont*eel6
10754       return
10755       end
10756 c--------------------------------------------------------------------------
10757       double precision function eello6_graph1(i,j,k,l,imat,swap)
10758       implicit real*8 (a-h,o-z)
10759       include 'DIMENSIONS'
10760       include 'COMMON.IOUNITS'
10761       include 'COMMON.CHAIN'
10762       include 'COMMON.DERIV'
10763       include 'COMMON.INTERACT'
10764       include 'COMMON.CONTACTS'
10765       include 'COMMON.CONTMAT'
10766       include 'COMMON.CORRMAT'
10767       include 'COMMON.TORSION'
10768       include 'COMMON.VAR'
10769       include 'COMMON.GEO'
10770       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10771       logical swap
10772       logical lprn
10773       common /kutas/ lprn
10774 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10775 C                                                                              C
10776 C      Parallel       Antiparallel                                             C
10777 C                                                                              C
10778 C          o             o                                                     C
10779 C         /l\           /j\                                                    C
10780 C        /   \         /   \                                                   C
10781 C       /| o |         | o |\                                                  C
10782 C     \ j|/k\|  /   \  |/k\|l /                                                C
10783 C      \ /   \ /     \ /   \ /                                                 C
10784 C       o     o       o     o                                                  C
10785 C       i             i                                                        C
10786 C                                                                              C
10787 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10788       itk=itype2loc(itype(k))
10789       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10790       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10791       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10792       call transpose2(EUgC(1,1,k),auxmat(1,1))
10793       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10794       vv1(1)=pizda1(1,1)-pizda1(2,2)
10795       vv1(2)=pizda1(1,2)+pizda1(2,1)
10796       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10797       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10798       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10799       s5=scalar2(vv(1),Dtobr2(1,i))
10800 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10801       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10802       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10803      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10804      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10805      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10806      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10807      & +scalar2(vv(1),Dtobr2der(1,i)))
10808       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10809       vv1(1)=pizda1(1,1)-pizda1(2,2)
10810       vv1(2)=pizda1(1,2)+pizda1(2,1)
10811       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10812       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10813       if (l.eq.j+1) then
10814         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10815      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10816      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10817      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10818      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10819       else
10820         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10821      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10822      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10823      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10824      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10825       endif
10826       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10827       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10828       vv1(1)=pizda1(1,1)-pizda1(2,2)
10829       vv1(2)=pizda1(1,2)+pizda1(2,1)
10830       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10831      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10832      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10833      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10834       do iii=1,2
10835         if (swap) then
10836           ind=3-iii
10837         else
10838           ind=iii
10839         endif
10840         do kkk=1,5
10841           do lll=1,3
10842             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10843             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10844             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10845             call transpose2(EUgC(1,1,k),auxmat(1,1))
10846             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10847      &        pizda1(1,1))
10848             vv1(1)=pizda1(1,1)-pizda1(2,2)
10849             vv1(2)=pizda1(1,2)+pizda1(2,1)
10850             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10851             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10852      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10853             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10854      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10855             s5=scalar2(vv(1),Dtobr2(1,i))
10856             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10857           enddo
10858         enddo
10859       enddo
10860       return
10861       end
10862 c----------------------------------------------------------------------------
10863       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10864       implicit real*8 (a-h,o-z)
10865       include 'DIMENSIONS'
10866       include 'COMMON.IOUNITS'
10867       include 'COMMON.CHAIN'
10868       include 'COMMON.DERIV'
10869       include 'COMMON.INTERACT'
10870       include 'COMMON.CONTACTS'
10871       include 'COMMON.CONTMAT'
10872       include 'COMMON.CORRMAT'
10873       include 'COMMON.TORSION'
10874       include 'COMMON.VAR'
10875       include 'COMMON.GEO'
10876       logical swap
10877       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10878      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10879       logical lprn
10880       common /kutas/ lprn
10881 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10882 C                                                                              C
10883 C      Parallel       Antiparallel                                             C
10884 C                                                                              C
10885 C          o             o                                                     C
10886 C     \   /l\           /j\   /                                                C
10887 C      \ /   \         /   \ /                                                 C
10888 C       o| o |         | o |o                                                  C
10889 C     \ j|/k\|      \  |/k\|l                                                  C
10890 C      \ /   \       \ /   \                                                   C
10891 C       o             o                                                        C
10892 C       i             i                                                        C
10893 C                                                                              C
10894 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10895 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10896 C AL 7/4/01 s1 would occur in the sixth-order moment,
10897 C           but not in a cluster cumulant
10898 #ifdef MOMENT
10899       s1=dip(1,jj,i)*dip(1,kk,k)
10900 #endif
10901       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10902       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10903       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10904       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10905       call transpose2(EUg(1,1,k),auxmat(1,1))
10906       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10907       vv(1)=pizda(1,1)-pizda(2,2)
10908       vv(2)=pizda(1,2)+pizda(2,1)
10909       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10910 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10911 #ifdef MOMENT
10912       eello6_graph2=-(s1+s2+s3+s4)
10913 #else
10914       eello6_graph2=-(s2+s3+s4)
10915 #endif
10916 c      eello6_graph2=-s3
10917 C Derivatives in gamma(i-1)
10918       if (i.gt.1) then
10919 #ifdef MOMENT
10920         s1=dipderg(1,jj,i)*dip(1,kk,k)
10921 #endif
10922         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10923         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10924         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10925         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10926 #ifdef MOMENT
10927         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10928 #else
10929         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10930 #endif
10931 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10932       endif
10933 C Derivatives in gamma(k-1)
10934 #ifdef MOMENT
10935       s1=dip(1,jj,i)*dipderg(1,kk,k)
10936 #endif
10937       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10938       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10939       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10940       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10941       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10942       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10943       vv(1)=pizda(1,1)-pizda(2,2)
10944       vv(2)=pizda(1,2)+pizda(2,1)
10945       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10946 #ifdef MOMENT
10947       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10948 #else
10949       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10950 #endif
10951 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10952 C Derivatives in gamma(j-1) or gamma(l-1)
10953       if (j.gt.1) then
10954 #ifdef MOMENT
10955         s1=dipderg(3,jj,i)*dip(1,kk,k)
10956 #endif
10957         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10958         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10959         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10960         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10961         vv(1)=pizda(1,1)-pizda(2,2)
10962         vv(2)=pizda(1,2)+pizda(2,1)
10963         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10964 #ifdef MOMENT
10965         if (swap) then
10966           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10967         else
10968           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10969         endif
10970 #endif
10971         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10972 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10973       endif
10974 C Derivatives in gamma(l-1) or gamma(j-1)
10975       if (l.gt.1) then
10976 #ifdef MOMENT
10977         s1=dip(1,jj,i)*dipderg(3,kk,k)
10978 #endif
10979         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10980         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10981         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10982         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10983         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10984         vv(1)=pizda(1,1)-pizda(2,2)
10985         vv(2)=pizda(1,2)+pizda(2,1)
10986         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10987 #ifdef MOMENT
10988         if (swap) then
10989           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10990         else
10991           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10992         endif
10993 #endif
10994         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10995 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10996       endif
10997 C Cartesian derivatives.
10998       if (lprn) then
10999         write (2,*) 'In eello6_graph2'
11000         do iii=1,2
11001           write (2,*) 'iii=',iii
11002           do kkk=1,5
11003             write (2,*) 'kkk=',kkk
11004             do jjj=1,2
11005               write (2,'(3(2f10.5),5x)')
11006      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11007             enddo
11008           enddo
11009         enddo
11010       endif
11011       do iii=1,2
11012         do kkk=1,5
11013           do lll=1,3
11014 #ifdef MOMENT
11015             if (iii.eq.1) then
11016               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11017             else
11018               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11019             endif
11020 #endif
11021             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11022      &        auxvec(1))
11023             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11024             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11025      &        auxvec(1))
11026             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11027             call transpose2(EUg(1,1,k),auxmat(1,1))
11028             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11029      &        pizda(1,1))
11030             vv(1)=pizda(1,1)-pizda(2,2)
11031             vv(2)=pizda(1,2)+pizda(2,1)
11032             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11033 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11034 #ifdef MOMENT
11035             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11036 #else
11037             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11038 #endif
11039             if (swap) then
11040               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11041             else
11042               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11043             endif
11044           enddo
11045         enddo
11046       enddo
11047       return
11048       end
11049 c----------------------------------------------------------------------------
11050       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11051       implicit real*8 (a-h,o-z)
11052       include 'DIMENSIONS'
11053       include 'COMMON.IOUNITS'
11054       include 'COMMON.CHAIN'
11055       include 'COMMON.DERIV'
11056       include 'COMMON.INTERACT'
11057       include 'COMMON.CONTACTS'
11058       include 'COMMON.CONTMAT'
11059       include 'COMMON.CORRMAT'
11060       include 'COMMON.TORSION'
11061       include 'COMMON.VAR'
11062       include 'COMMON.GEO'
11063       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11064       logical swap
11065 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11066 C                                                                              C
11067 C      Parallel       Antiparallel                                             C
11068 C                                                                              C
11069 C          o             o                                                     C
11070 C         /l\   /   \   /j\                                                    C
11071 C        /   \ /     \ /   \                                                   C
11072 C       /| o |o       o| o |\                                                  C
11073 C       j|/k\|  /      |/k\|l /                                                C
11074 C        /   \ /       /   \ /                                                 C
11075 C       /     o       /     o                                                  C
11076 C       i             i                                                        C
11077 C                                                                              C
11078 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11079 C
11080 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11081 C           energy moment and not to the cluster cumulant.
11082       iti=itortyp(itype(i))
11083       if (j.lt.nres-1) then
11084         itj1=itype2loc(itype(j+1))
11085       else
11086         itj1=nloctyp
11087       endif
11088       itk=itype2loc(itype(k))
11089       itk1=itype2loc(itype(k+1))
11090       if (l.lt.nres-1) then
11091         itl1=itype2loc(itype(l+1))
11092       else
11093         itl1=nloctyp
11094       endif
11095 #ifdef MOMENT
11096       s1=dip(4,jj,i)*dip(4,kk,k)
11097 #endif
11098       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11099       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11100       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11101       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11102       call transpose2(EE(1,1,k),auxmat(1,1))
11103       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11104       vv(1)=pizda(1,1)+pizda(2,2)
11105       vv(2)=pizda(2,1)-pizda(1,2)
11106       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11107 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11108 cd     & "sum",-(s2+s3+s4)
11109 #ifdef MOMENT
11110       eello6_graph3=-(s1+s2+s3+s4)
11111 #else
11112       eello6_graph3=-(s2+s3+s4)
11113 #endif
11114 c      eello6_graph3=-s4
11115 C Derivatives in gamma(k-1)
11116       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11117       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11118       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11119       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11120 C Derivatives in gamma(l-1)
11121       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11122       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11123       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11124       vv(1)=pizda(1,1)+pizda(2,2)
11125       vv(2)=pizda(2,1)-pizda(1,2)
11126       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11127       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11128 C Cartesian derivatives.
11129       do iii=1,2
11130         do kkk=1,5
11131           do lll=1,3
11132 #ifdef MOMENT
11133             if (iii.eq.1) then
11134               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11135             else
11136               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11137             endif
11138 #endif
11139             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11140      &        auxvec(1))
11141             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11142             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11143      &        auxvec(1))
11144             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11145             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11146      &        pizda(1,1))
11147             vv(1)=pizda(1,1)+pizda(2,2)
11148             vv(2)=pizda(2,1)-pizda(1,2)
11149             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11150 #ifdef MOMENT
11151             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11152 #else
11153             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11154 #endif
11155             if (swap) then
11156               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11157             else
11158               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11159             endif
11160 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11161           enddo
11162         enddo
11163       enddo
11164       return
11165       end
11166 c----------------------------------------------------------------------------
11167       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11168       implicit real*8 (a-h,o-z)
11169       include 'DIMENSIONS'
11170       include 'COMMON.IOUNITS'
11171       include 'COMMON.CHAIN'
11172       include 'COMMON.DERIV'
11173       include 'COMMON.INTERACT'
11174       include 'COMMON.CONTACTS'
11175       include 'COMMON.CONTMAT'
11176       include 'COMMON.CORRMAT'
11177       include 'COMMON.TORSION'
11178       include 'COMMON.VAR'
11179       include 'COMMON.GEO'
11180       include 'COMMON.FFIELD'
11181       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11182      & auxvec1(2),auxmat1(2,2)
11183       logical swap
11184 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11185 C                                                                              C
11186 C      Parallel       Antiparallel                                             C
11187 C                                                                              C
11188 C          o             o                                                     C
11189 C         /l\   /   \   /j\                                                    C
11190 C        /   \ /     \ /   \                                                   C
11191 C       /| o |o       o| o |\                                                  C
11192 C     \ j|/k\|      \  |/k\|l                                                  C
11193 C      \ /   \       \ /   \                                                   C
11194 C       o     \       o     \                                                  C
11195 C       i             i                                                        C
11196 C                                                                              C
11197 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11198 C
11199 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11200 C           energy moment and not to the cluster cumulant.
11201 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11202       iti=itype2loc(itype(i))
11203       itj=itype2loc(itype(j))
11204       if (j.lt.nres-1) then
11205         itj1=itype2loc(itype(j+1))
11206       else
11207         itj1=nloctyp
11208       endif
11209       itk=itype2loc(itype(k))
11210       if (k.lt.nres-1) then
11211         itk1=itype2loc(itype(k+1))
11212       else
11213         itk1=nloctyp
11214       endif
11215       itl=itype2loc(itype(l))
11216       if (l.lt.nres-1) then
11217         itl1=itype2loc(itype(l+1))
11218       else
11219         itl1=nloctyp
11220       endif
11221 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11222 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11223 cd     & ' itl',itl,' itl1',itl1
11224 #ifdef MOMENT
11225       if (imat.eq.1) then
11226         s1=dip(3,jj,i)*dip(3,kk,k)
11227       else
11228         s1=dip(2,jj,j)*dip(2,kk,l)
11229       endif
11230 #endif
11231       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11232       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11233       if (j.eq.l+1) then
11234         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11235         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11236       else
11237         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11238         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11239       endif
11240       call transpose2(EUg(1,1,k),auxmat(1,1))
11241       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11242       vv(1)=pizda(1,1)-pizda(2,2)
11243       vv(2)=pizda(2,1)+pizda(1,2)
11244       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11245 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11246 #ifdef MOMENT
11247       eello6_graph4=-(s1+s2+s3+s4)
11248 #else
11249       eello6_graph4=-(s2+s3+s4)
11250 #endif
11251 C Derivatives in gamma(i-1)
11252       if (i.gt.1) then
11253 #ifdef MOMENT
11254         if (imat.eq.1) then
11255           s1=dipderg(2,jj,i)*dip(3,kk,k)
11256         else
11257           s1=dipderg(4,jj,j)*dip(2,kk,l)
11258         endif
11259 #endif
11260         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11261         if (j.eq.l+1) then
11262           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11263           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11264         else
11265           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11266           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11267         endif
11268         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11269         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11270 cd          write (2,*) 'turn6 derivatives'
11271 #ifdef MOMENT
11272           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11273 #else
11274           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11275 #endif
11276         else
11277 #ifdef MOMENT
11278           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11279 #else
11280           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11281 #endif
11282         endif
11283       endif
11284 C Derivatives in gamma(k-1)
11285 #ifdef MOMENT
11286       if (imat.eq.1) then
11287         s1=dip(3,jj,i)*dipderg(2,kk,k)
11288       else
11289         s1=dip(2,jj,j)*dipderg(4,kk,l)
11290       endif
11291 #endif
11292       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11293       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11294       if (j.eq.l+1) then
11295         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11296         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11297       else
11298         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11299         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11300       endif
11301       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11302       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11303       vv(1)=pizda(1,1)-pizda(2,2)
11304       vv(2)=pizda(2,1)+pizda(1,2)
11305       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11306       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11307 #ifdef MOMENT
11308         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11309 #else
11310         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11311 #endif
11312       else
11313 #ifdef MOMENT
11314         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11315 #else
11316         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11317 #endif
11318       endif
11319 C Derivatives in gamma(j-1) or gamma(l-1)
11320       if (l.eq.j+1 .and. l.gt.1) then
11321         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11322         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11323         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11324         vv(1)=pizda(1,1)-pizda(2,2)
11325         vv(2)=pizda(2,1)+pizda(1,2)
11326         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11327         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11328       else if (j.gt.1) then
11329         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11330         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11331         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11332         vv(1)=pizda(1,1)-pizda(2,2)
11333         vv(2)=pizda(2,1)+pizda(1,2)
11334         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11335         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11336           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11337         else
11338           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11339         endif
11340       endif
11341 C Cartesian derivatives.
11342       do iii=1,2
11343         do kkk=1,5
11344           do lll=1,3
11345 #ifdef MOMENT
11346             if (iii.eq.1) then
11347               if (imat.eq.1) then
11348                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11349               else
11350                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11351               endif
11352             else
11353               if (imat.eq.1) then
11354                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11355               else
11356                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11357               endif
11358             endif
11359 #endif
11360             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11361      &        auxvec(1))
11362             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11363             if (j.eq.l+1) then
11364               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11365      &          b1(1,j+1),auxvec(1))
11366               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11367             else
11368               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11369      &          b1(1,l+1),auxvec(1))
11370               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11371             endif
11372             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11373      &        pizda(1,1))
11374             vv(1)=pizda(1,1)-pizda(2,2)
11375             vv(2)=pizda(2,1)+pizda(1,2)
11376             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11377             if (swap) then
11378               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11379 #ifdef MOMENT
11380                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11381      &             -(s1+s2+s4)
11382 #else
11383                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11384      &             -(s2+s4)
11385 #endif
11386                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11387               else
11388 #ifdef MOMENT
11389                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11390 #else
11391                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11392 #endif
11393                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11394               endif
11395             else
11396 #ifdef MOMENT
11397               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11398 #else
11399               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11400 #endif
11401               if (l.eq.j+1) then
11402                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11403               else
11404                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11405               endif
11406             endif
11407           enddo
11408         enddo
11409       enddo
11410       return
11411       end
11412 c----------------------------------------------------------------------------
11413       double precision function eello_turn6(i,jj,kk)
11414       implicit real*8 (a-h,o-z)
11415       include 'DIMENSIONS'
11416       include 'COMMON.IOUNITS'
11417       include 'COMMON.CHAIN'
11418       include 'COMMON.DERIV'
11419       include 'COMMON.INTERACT'
11420       include 'COMMON.CONTACTS'
11421       include 'COMMON.CONTMAT'
11422       include 'COMMON.CORRMAT'
11423       include 'COMMON.TORSION'
11424       include 'COMMON.VAR'
11425       include 'COMMON.GEO'
11426       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11427      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11428      &  ggg1(3),ggg2(3)
11429       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11430      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11431 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11432 C           the respective energy moment and not to the cluster cumulant.
11433       s1=0.0d0
11434       s8=0.0d0
11435       s13=0.0d0
11436 c
11437       eello_turn6=0.0d0
11438       j=i+4
11439       k=i+1
11440       l=i+3
11441       iti=itype2loc(itype(i))
11442       itk=itype2loc(itype(k))
11443       itk1=itype2loc(itype(k+1))
11444       itl=itype2loc(itype(l))
11445       itj=itype2loc(itype(j))
11446 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11447 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11448 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11449 cd        eello6=0.0d0
11450 cd        return
11451 cd      endif
11452 cd      write (iout,*)
11453 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11454 cd     &   ' and',k,l
11455 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11456       do iii=1,2
11457         do kkk=1,5
11458           do lll=1,3
11459             derx_turn(lll,kkk,iii)=0.0d0
11460           enddo
11461         enddo
11462       enddo
11463 cd      eij=1.0d0
11464 cd      ekl=1.0d0
11465 cd      ekont=1.0d0
11466       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11467 cd      eello6_5=0.0d0
11468 cd      write (2,*) 'eello6_5',eello6_5
11469 #ifdef MOMENT
11470       call transpose2(AEA(1,1,1),auxmat(1,1))
11471       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11472       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11473       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11474 #endif
11475       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11476       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11477       s2 = scalar2(b1(1,k),vtemp1(1))
11478 #ifdef MOMENT
11479       call transpose2(AEA(1,1,2),atemp(1,1))
11480       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11481       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11482       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11483 #endif
11484       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11485       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11486       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11487 #ifdef MOMENT
11488       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11489       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11490       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11491       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11492       ss13 = scalar2(b1(1,k),vtemp4(1))
11493       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11494 #endif
11495 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11496 c      s1=0.0d0
11497 c      s2=0.0d0
11498 c      s8=0.0d0
11499 c      s12=0.0d0
11500 c      s13=0.0d0
11501       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11502 C Derivatives in gamma(i+2)
11503       s1d =0.0d0
11504       s8d =0.0d0
11505 #ifdef MOMENT
11506       call transpose2(AEA(1,1,1),auxmatd(1,1))
11507       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11508       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11509       call transpose2(AEAderg(1,1,2),atempd(1,1))
11510       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11511       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11512 #endif
11513       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11514       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11515       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11516 c      s1d=0.0d0
11517 c      s2d=0.0d0
11518 c      s8d=0.0d0
11519 c      s12d=0.0d0
11520 c      s13d=0.0d0
11521       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11522 C Derivatives in gamma(i+3)
11523 #ifdef MOMENT
11524       call transpose2(AEA(1,1,1),auxmatd(1,1))
11525       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11526       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11527       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11528 #endif
11529       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11530       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11531       s2d = scalar2(b1(1,k),vtemp1d(1))
11532 #ifdef MOMENT
11533       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11534       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11535 #endif
11536       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11537 #ifdef MOMENT
11538       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11539       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11540       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11541 #endif
11542 c      s1d=0.0d0
11543 c      s2d=0.0d0
11544 c      s8d=0.0d0
11545 c      s12d=0.0d0
11546 c      s13d=0.0d0
11547 #ifdef MOMENT
11548       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11549      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11550 #else
11551       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11552      &               -0.5d0*ekont*(s2d+s12d)
11553 #endif
11554 C Derivatives in gamma(i+4)
11555       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11556       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11557       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11558 #ifdef MOMENT
11559       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11560       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11561       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11562 #endif
11563 c      s1d=0.0d0
11564 c      s2d=0.0d0
11565 c      s8d=0.0d0
11566 C      s12d=0.0d0
11567 c      s13d=0.0d0
11568 #ifdef MOMENT
11569       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11570 #else
11571       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11572 #endif
11573 C Derivatives in gamma(i+5)
11574 #ifdef MOMENT
11575       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11576       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11577       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11578 #endif
11579       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11580       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11581       s2d = scalar2(b1(1,k),vtemp1d(1))
11582 #ifdef MOMENT
11583       call transpose2(AEA(1,1,2),atempd(1,1))
11584       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11585       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11586 #endif
11587       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11588       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11589 #ifdef MOMENT
11590       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11591       ss13d = scalar2(b1(1,k),vtemp4d(1))
11592       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11593 #endif
11594 c      s1d=0.0d0
11595 c      s2d=0.0d0
11596 c      s8d=0.0d0
11597 c      s12d=0.0d0
11598 c      s13d=0.0d0
11599 #ifdef MOMENT
11600       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11601      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11602 #else
11603       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11604      &               -0.5d0*ekont*(s2d+s12d)
11605 #endif
11606 C Cartesian derivatives
11607       do iii=1,2
11608         do kkk=1,5
11609           do lll=1,3
11610 #ifdef MOMENT
11611             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11612             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11613             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11614 #endif
11615             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11616             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11617      &          vtemp1d(1))
11618             s2d = scalar2(b1(1,k),vtemp1d(1))
11619 #ifdef MOMENT
11620             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11621             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11622             s8d = -(atempd(1,1)+atempd(2,2))*
11623      &           scalar2(cc(1,1,l),vtemp2(1))
11624 #endif
11625             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11626      &           auxmatd(1,1))
11627             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11628             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11629 c      s1d=0.0d0
11630 c      s2d=0.0d0
11631 c      s8d=0.0d0
11632 c      s12d=0.0d0
11633 c      s13d=0.0d0
11634 #ifdef MOMENT
11635             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11636      &        - 0.5d0*(s1d+s2d)
11637 #else
11638             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11639      &        - 0.5d0*s2d
11640 #endif
11641 #ifdef MOMENT
11642             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11643      &        - 0.5d0*(s8d+s12d)
11644 #else
11645             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11646      &        - 0.5d0*s12d
11647 #endif
11648           enddo
11649         enddo
11650       enddo
11651 #ifdef MOMENT
11652       do kkk=1,5
11653         do lll=1,3
11654           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11655      &      achuj_tempd(1,1))
11656           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11657           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11658           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11659           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11660           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11661      &      vtemp4d(1))
11662           ss13d = scalar2(b1(1,k),vtemp4d(1))
11663           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11664           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11665         enddo
11666       enddo
11667 #endif
11668 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11669 cd     &  16*eel_turn6_num
11670 cd      goto 1112
11671       if (j.lt.nres-1) then
11672         j1=j+1
11673         j2=j-1
11674       else
11675         j1=j-1
11676         j2=j-2
11677       endif
11678       if (l.lt.nres-1) then
11679         l1=l+1
11680         l2=l-1
11681       else
11682         l1=l-1
11683         l2=l-2
11684       endif
11685       do ll=1,3
11686 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11687 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11688 cgrad        ghalf=0.5d0*ggg1(ll)
11689 cd        ghalf=0.0d0
11690         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11691         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11692         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11693      &    +ekont*derx_turn(ll,2,1)
11694         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11695         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11696      &    +ekont*derx_turn(ll,4,1)
11697         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11698         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11699         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11700 cgrad        ghalf=0.5d0*ggg2(ll)
11701 cd        ghalf=0.0d0
11702         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11703      &    +ekont*derx_turn(ll,2,2)
11704         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11705         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11706      &    +ekont*derx_turn(ll,4,2)
11707         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11708         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11709         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11710       enddo
11711 cd      goto 1112
11712 cgrad      do m=i+1,j-1
11713 cgrad        do ll=1,3
11714 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11715 cgrad        enddo
11716 cgrad      enddo
11717 cgrad      do m=k+1,l-1
11718 cgrad        do ll=1,3
11719 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11720 cgrad        enddo
11721 cgrad      enddo
11722 cgrad1112  continue
11723 cgrad      do m=i+2,j2
11724 cgrad        do ll=1,3
11725 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11726 cgrad        enddo
11727 cgrad      enddo
11728 cgrad      do m=k+2,l2
11729 cgrad        do ll=1,3
11730 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11731 cgrad        enddo
11732 cgrad      enddo
11733 cd      do iii=1,nres-3
11734 cd        write (2,*) iii,g_corr6_loc(iii)
11735 cd      enddo
11736       eello_turn6=ekont*eel_turn6
11737 cd      write (2,*) 'ekont',ekont
11738 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11739       return
11740       end
11741 C-----------------------------------------------------------------------------
11742 #endif
11743       double precision function scalar(u,v)
11744 !DIR$ INLINEALWAYS scalar
11745 #ifndef OSF
11746 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11747 #endif
11748       implicit none
11749       double precision u(3),v(3)
11750 cd      double precision sc
11751 cd      integer i
11752 cd      sc=0.0d0
11753 cd      do i=1,3
11754 cd        sc=sc+u(i)*v(i)
11755 cd      enddo
11756 cd      scalar=sc
11757
11758       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11759       return
11760       end
11761 crc-------------------------------------------------
11762       SUBROUTINE MATVEC2(A1,V1,V2)
11763 !DIR$ INLINEALWAYS MATVEC2
11764 #ifndef OSF
11765 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11766 #endif
11767       implicit real*8 (a-h,o-z)
11768       include 'DIMENSIONS'
11769       DIMENSION A1(2,2),V1(2),V2(2)
11770 c      DO 1 I=1,2
11771 c        VI=0.0
11772 c        DO 3 K=1,2
11773 c    3     VI=VI+A1(I,K)*V1(K)
11774 c        Vaux(I)=VI
11775 c    1 CONTINUE
11776
11777       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11778       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11779
11780       v2(1)=vaux1
11781       v2(2)=vaux2
11782       END
11783 C---------------------------------------
11784       SUBROUTINE MATMAT2(A1,A2,A3)
11785 #ifndef OSF
11786 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11787 #endif
11788       implicit real*8 (a-h,o-z)
11789       include 'DIMENSIONS'
11790       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11791 c      DIMENSION AI3(2,2)
11792 c        DO  J=1,2
11793 c          A3IJ=0.0
11794 c          DO K=1,2
11795 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11796 c          enddo
11797 c          A3(I,J)=A3IJ
11798 c       enddo
11799 c      enddo
11800
11801       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11802       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11803       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11804       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11805
11806       A3(1,1)=AI3_11
11807       A3(2,1)=AI3_21
11808       A3(1,2)=AI3_12
11809       A3(2,2)=AI3_22
11810       END
11811
11812 c-------------------------------------------------------------------------
11813       double precision function scalar2(u,v)
11814 !DIR$ INLINEALWAYS scalar2
11815       implicit none
11816       double precision u(2),v(2)
11817       double precision sc
11818       integer i
11819       scalar2=u(1)*v(1)+u(2)*v(2)
11820       return
11821       end
11822
11823 C-----------------------------------------------------------------------------
11824
11825       subroutine transpose2(a,at)
11826 !DIR$ INLINEALWAYS transpose2
11827 #ifndef OSF
11828 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11829 #endif
11830       implicit none
11831       double precision a(2,2),at(2,2)
11832       at(1,1)=a(1,1)
11833       at(1,2)=a(2,1)
11834       at(2,1)=a(1,2)
11835       at(2,2)=a(2,2)
11836       return
11837       end
11838 c--------------------------------------------------------------------------
11839       subroutine transpose(n,a,at)
11840       implicit none
11841       integer n,i,j
11842       double precision a(n,n),at(n,n)
11843       do i=1,n
11844         do j=1,n
11845           at(j,i)=a(i,j)
11846         enddo
11847       enddo
11848       return
11849       end
11850 C---------------------------------------------------------------------------
11851       subroutine prodmat3(a1,a2,kk,transp,prod)
11852 !DIR$ INLINEALWAYS prodmat3
11853 #ifndef OSF
11854 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11855 #endif
11856       implicit none
11857       integer i,j
11858       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11859       logical transp
11860 crc      double precision auxmat(2,2),prod_(2,2)
11861
11862       if (transp) then
11863 crc        call transpose2(kk(1,1),auxmat(1,1))
11864 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11865 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11866
11867            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11868      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11869            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11870      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11871            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11872      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11873            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11874      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11875
11876       else
11877 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11878 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11879
11880            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11881      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11882            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11883      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11884            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11885      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11886            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11887      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11888
11889       endif
11890 c      call transpose2(a2(1,1),a2t(1,1))
11891
11892 crc      print *,transp
11893 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11894 crc      print *,((prod(i,j),i=1,2),j=1,2)
11895
11896       return
11897       end
11898 CCC----------------------------------------------
11899       subroutine Eliptransfer(eliptran)
11900       implicit real*8 (a-h,o-z)
11901       include 'DIMENSIONS'
11902       include 'COMMON.GEO'
11903       include 'COMMON.VAR'
11904       include 'COMMON.LOCAL'
11905       include 'COMMON.CHAIN'
11906       include 'COMMON.DERIV'
11907       include 'COMMON.NAMES'
11908       include 'COMMON.INTERACT'
11909       include 'COMMON.IOUNITS'
11910       include 'COMMON.CALC'
11911       include 'COMMON.CONTROL'
11912       include 'COMMON.SPLITELE'
11913       include 'COMMON.SBRIDGE'
11914 C this is done by Adasko
11915 C      print *,"wchodze"
11916 C structure of box:
11917 C      water
11918 C--bordliptop-- buffore starts
11919 C--bufliptop--- here true lipid starts
11920 C      lipid
11921 C--buflipbot--- lipid ends buffore starts
11922 C--bordlipbot--buffore ends
11923 c      call cartprint
11924       eliptran=0.0
11925       do i=ilip_start,ilip_end
11926 C       do i=1,1
11927         if (itype(i).eq.ntyp1) cycle
11928
11929         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11930         if (positi.le.0.0) positi=positi+boxzsize
11931 C        print *,i
11932 C first for peptide groups
11933 c for each residue check if it is in lipid or lipid water border area
11934        if ((positi.gt.bordlipbot)
11935      &.and.(positi.lt.bordliptop)) then
11936 C the energy transfer exist
11937         if (positi.lt.buflipbot) then
11938 C what fraction I am in
11939          fracinbuf=1.0d0-
11940      &        ((positi-bordlipbot)/lipbufthick)
11941 C lipbufthick is thickenes of lipid buffore
11942          sslip=sscalelip(fracinbuf)
11943          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11944          eliptran=eliptran+sslip*pepliptran
11945          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11946          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11947 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11948
11949 C        print *,"doing sccale for lower part"
11950 C         print *,i,sslip,fracinbuf,ssgradlip
11951         elseif (positi.gt.bufliptop) then
11952          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11953          sslip=sscalelip(fracinbuf)
11954          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11955          eliptran=eliptran+sslip*pepliptran
11956          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11957          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11958 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11959 C          print *, "doing sscalefor top part"
11960 C         print *,i,sslip,fracinbuf,ssgradlip
11961         else
11962          eliptran=eliptran+pepliptran
11963 C         print *,"I am in true lipid"
11964         endif
11965 C       else
11966 C       eliptran=elpitran+0.0 ! I am in water
11967        endif
11968        enddo
11969 C       print *, "nic nie bylo w lipidzie?"
11970 C now multiply all by the peptide group transfer factor
11971 C       eliptran=eliptran*pepliptran
11972 C now the same for side chains
11973 CV       do i=1,1
11974        do i=ilip_start,ilip_end
11975         if (itype(i).eq.ntyp1) cycle
11976         positi=(mod(c(3,i+nres),boxzsize))
11977         if (positi.le.0) positi=positi+boxzsize
11978 c        write(iout,*) "i",i," positi",positi,bordlipbot,buflipbot,
11979 c     &   bordliptop
11980 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11981 c for each residue check if it is in lipid or lipid water border area
11982 C       respos=mod(c(3,i+nres),boxzsize)
11983 C       print *,positi,bordlipbot,buflipbot
11984        if ((positi.gt.bordlipbot)
11985      & .and.(positi.lt.bordliptop)) then
11986 C the energy transfer exist
11987         if (positi.lt.buflipbot) then
11988          fracinbuf=1.0d0-
11989      &     ((positi-bordlipbot)/lipbufthick)
11990 c         write (iout,*) "i",i,itype(i)," fracinbuf",fracinbuf
11991 c         write (iout,*) "i",i," liptranene",liptranene(itype(i))
11992 C lipbufthick is thickenes of lipid buffore
11993          sslip=sscalelip(fracinbuf)
11994          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11995          eliptran=eliptran+sslip*liptranene(itype(i))
11996          gliptranx(3,i)=gliptranx(3,i)
11997      &+ssgradlip*liptranene(itype(i))
11998          gliptranc(3,i-1)= gliptranc(3,i-1)
11999      &+ssgradlip*liptranene(itype(i))
12000 C         print *,"doing sccale for lower part"
12001         elseif (positi.gt.bufliptop) then
12002          fracinbuf=1.0d0-
12003      &((bordliptop-positi)/lipbufthick)
12004          sslip=sscalelip(fracinbuf)
12005          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12006          eliptran=eliptran+sslip*liptranene(itype(i))
12007          gliptranx(3,i)=gliptranx(3,i)
12008      &+ssgradlip*liptranene(itype(i))
12009          gliptranc(3,i-1)= gliptranc(3,i-1)
12010      &+ssgradlip*liptranene(itype(i))
12011 C          print *, "doing sscalefor top part",sslip,fracinbuf
12012         else
12013          eliptran=eliptran+liptranene(itype(i))
12014 C         print *,"I am in true lipid"
12015         endif
12016         endif ! if in lipid or buffor
12017 C       else
12018 C       eliptran=elpitran+0.0 ! I am in water
12019        enddo
12020        return
12021        end
12022 C---------------------------------------------------------
12023 C AFM soubroutine for constant force
12024        subroutine AFMforce(Eafmforce)
12025        implicit real*8 (a-h,o-z)
12026       include 'DIMENSIONS'
12027       include 'COMMON.GEO'
12028       include 'COMMON.VAR'
12029       include 'COMMON.LOCAL'
12030       include 'COMMON.CHAIN'
12031       include 'COMMON.DERIV'
12032       include 'COMMON.NAMES'
12033       include 'COMMON.INTERACT'
12034       include 'COMMON.IOUNITS'
12035       include 'COMMON.CALC'
12036       include 'COMMON.CONTROL'
12037       include 'COMMON.SPLITELE'
12038       include 'COMMON.SBRIDGE'
12039       real*8 diffafm(3)
12040       dist=0.0d0
12041       Eafmforce=0.0d0
12042       do i=1,3
12043       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12044       dist=dist+diffafm(i)**2
12045       enddo
12046       dist=dsqrt(dist)
12047       Eafmforce=-forceAFMconst*(dist-distafminit)
12048       do i=1,3
12049       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12050       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12051       enddo
12052 C      print *,'AFM',Eafmforce
12053       return
12054       end
12055 C---------------------------------------------------------
12056 C AFM subroutine with pseudoconstant velocity
12057        subroutine AFMvel(Eafmforce)
12058        implicit real*8 (a-h,o-z)
12059       include 'DIMENSIONS'
12060       include 'COMMON.GEO'
12061       include 'COMMON.VAR'
12062       include 'COMMON.LOCAL'
12063       include 'COMMON.CHAIN'
12064       include 'COMMON.DERIV'
12065       include 'COMMON.NAMES'
12066       include 'COMMON.INTERACT'
12067       include 'COMMON.IOUNITS'
12068       include 'COMMON.CALC'
12069       include 'COMMON.CONTROL'
12070       include 'COMMON.SPLITELE'
12071       include 'COMMON.SBRIDGE'
12072       real*8 diffafm(3)
12073 C Only for check grad COMMENT if not used for checkgrad
12074 C      totT=3.0d0
12075 C--------------------------------------------------------
12076 C      print *,"wchodze"
12077       dist=0.0d0
12078       Eafmforce=0.0d0
12079       do i=1,3
12080       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12081       dist=dist+diffafm(i)**2
12082       enddo
12083       dist=dsqrt(dist)
12084       Eafmforce=0.5d0*forceAFMconst
12085      & *(distafminit+totTafm*velAFMconst-dist)**2
12086 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12087       do i=1,3
12088       gradafm(i,afmend-1)=-forceAFMconst*
12089      &(distafminit+totTafm*velAFMconst-dist)
12090      &*diffafm(i)/dist
12091       gradafm(i,afmbeg-1)=forceAFMconst*
12092      &(distafminit+totTafm*velAFMconst-dist)
12093      &*diffafm(i)/dist
12094       enddo
12095 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12096       return
12097       end
12098 C-----------------------------------------------------------
12099 C first for shielding is setting of function of side-chains
12100        subroutine set_shield_fac
12101       implicit real*8 (a-h,o-z)
12102       include 'DIMENSIONS'
12103       include 'COMMON.CHAIN'
12104       include 'COMMON.DERIV'
12105       include 'COMMON.IOUNITS'
12106       include 'COMMON.SHIELD'
12107       include 'COMMON.INTERACT'
12108 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12109       double precision div77_81/0.974996043d0/,
12110      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12111
12112 C the vector between center of side_chain and peptide group
12113        double precision pep_side(3),long,side_calf(3),
12114      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12115      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12116 C the line belowe needs to be changed for FGPROC>1
12117       do i=1,nres-1
12118       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12119       ishield_list(i)=0
12120 Cif there two consequtive dummy atoms there is no peptide group between them
12121 C the line below has to be changed for FGPROC>1
12122       VolumeTotal=0.0
12123       do k=1,nres
12124        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12125        dist_pep_side=0.0
12126        dist_side_calf=0.0
12127        do j=1,3
12128 C first lets set vector conecting the ithe side-chain with kth side-chain
12129       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12130 C      pep_side(j)=2.0d0
12131 C and vector conecting the side-chain with its proper calfa
12132       side_calf(j)=c(j,k+nres)-c(j,k)
12133 C      side_calf(j)=2.0d0
12134       pept_group(j)=c(j,i)-c(j,i+1)
12135 C lets have their lenght
12136       dist_pep_side=pep_side(j)**2+dist_pep_side
12137       dist_side_calf=dist_side_calf+side_calf(j)**2
12138       dist_pept_group=dist_pept_group+pept_group(j)**2
12139       enddo
12140        dist_pep_side=dsqrt(dist_pep_side)
12141        dist_pept_group=dsqrt(dist_pept_group)
12142        dist_side_calf=dsqrt(dist_side_calf)
12143       do j=1,3
12144         pep_side_norm(j)=pep_side(j)/dist_pep_side
12145         side_calf_norm(j)=dist_side_calf
12146       enddo
12147 C now sscale fraction
12148        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12149 C       print *,buff_shield,"buff"
12150 C now sscale
12151         if (sh_frac_dist.le.0.0) cycle
12152 C If we reach here it means that this side chain reaches the shielding sphere
12153 C Lets add him to the list for gradient
12154         ishield_list(i)=ishield_list(i)+1
12155 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12156 C this list is essential otherwise problem would be O3
12157         shield_list(ishield_list(i),i)=k
12158 C Lets have the sscale value
12159         if (sh_frac_dist.gt.1.0) then
12160          scale_fac_dist=1.0d0
12161          do j=1,3
12162          sh_frac_dist_grad(j)=0.0d0
12163          enddo
12164         else
12165          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12166      &                   *(2.0*sh_frac_dist-3.0d0)
12167          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12168      &                  /dist_pep_side/buff_shield*0.5
12169 C remember for the final gradient multiply sh_frac_dist_grad(j)
12170 C for side_chain by factor -2 !
12171          do j=1,3
12172          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12173 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12174 C     &                    sh_frac_dist_grad(j)
12175          enddo
12176         endif
12177 C        if ((i.eq.3).and.(k.eq.2)) then
12178 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12179 C     & ,"TU"
12180 C        endif
12181
12182 C this is what is now we have the distance scaling now volume...
12183       short=short_r_sidechain(itype(k))
12184       long=long_r_sidechain(itype(k))
12185       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12186 C now costhet_grad
12187 C       costhet=0.0d0
12188        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12189 C       costhet_fac=0.0d0
12190        do j=1,3
12191          costhet_grad(j)=costhet_fac*pep_side(j)
12192        enddo
12193 C remember for the final gradient multiply costhet_grad(j)
12194 C for side_chain by factor -2 !
12195 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12196 C pep_side0pept_group is vector multiplication
12197       pep_side0pept_group=0.0
12198       do j=1,3
12199       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12200       enddo
12201       cosalfa=(pep_side0pept_group/
12202      & (dist_pep_side*dist_side_calf))
12203       fac_alfa_sin=1.0-cosalfa**2
12204       fac_alfa_sin=dsqrt(fac_alfa_sin)
12205       rkprim=fac_alfa_sin*(long-short)+short
12206 C now costhet_grad
12207        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12208        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12209
12210        do j=1,3
12211          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12212      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12213      &*(long-short)/fac_alfa_sin*cosalfa/
12214      &((dist_pep_side*dist_side_calf))*
12215      &((side_calf(j))-cosalfa*
12216      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12217
12218         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12219      &*(long-short)/fac_alfa_sin*cosalfa
12220      &/((dist_pep_side*dist_side_calf))*
12221      &(pep_side(j)-
12222      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12223        enddo
12224
12225       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12226      &                    /VSolvSphere_div
12227      &                    *wshield
12228 C now the gradient...
12229 C grad_shield is gradient of Calfa for peptide groups
12230 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12231 C     &               costhet,cosphi
12232 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12233 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12234       do j=1,3
12235       grad_shield(j,i)=grad_shield(j,i)
12236 C gradient po skalowaniu
12237      &                +(sh_frac_dist_grad(j)
12238 C  gradient po costhet
12239      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12240      &-scale_fac_dist*(cosphi_grad_long(j))
12241      &/(1.0-cosphi) )*div77_81
12242      &*VofOverlap
12243 C grad_shield_side is Cbeta sidechain gradient
12244       grad_shield_side(j,ishield_list(i),i)=
12245      &        (sh_frac_dist_grad(j)*(-2.0d0)
12246      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12247      &       +scale_fac_dist*(cosphi_grad_long(j))
12248      &        *2.0d0/(1.0-cosphi))
12249      &        *div77_81*VofOverlap
12250
12251        grad_shield_loc(j,ishield_list(i),i)=
12252      &   scale_fac_dist*cosphi_grad_loc(j)
12253      &        *2.0d0/(1.0-cosphi)
12254      &        *div77_81*VofOverlap
12255       enddo
12256       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12257       enddo
12258       fac_shield(i)=VolumeTotal*div77_81+div4_81
12259 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12260       enddo
12261       return
12262       end
12263 C--------------------------------------------------------------------------
12264       double precision function tschebyshev(m,n,x,y)
12265       implicit none
12266       include "DIMENSIONS"
12267       integer i,m,n
12268       double precision x(n),y,yy(0:maxvar),aux
12269 c Tschebyshev polynomial. Note that the first term is omitted
12270 c m=0: the constant term is included
12271 c m=1: the constant term is not included
12272       yy(0)=1.0d0
12273       yy(1)=y
12274       do i=2,n
12275         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12276       enddo
12277       aux=0.0d0
12278       do i=m,n
12279         aux=aux+x(i)*yy(i)
12280       enddo
12281       tschebyshev=aux
12282       return
12283       end
12284 C--------------------------------------------------------------------------
12285       double precision function gradtschebyshev(m,n,x,y)
12286       implicit none
12287       include "DIMENSIONS"
12288       integer i,m,n
12289       double precision x(n+1),y,yy(0:maxvar),aux
12290 c Tschebyshev polynomial. Note that the first term is omitted
12291 c m=0: the constant term is included
12292 c m=1: the constant term is not included
12293       yy(0)=1.0d0
12294       yy(1)=2.0d0*y
12295       do i=2,n
12296         yy(i)=2*y*yy(i-1)-yy(i-2)
12297       enddo
12298       aux=0.0d0
12299       do i=m,n
12300         aux=aux+x(i+1)*yy(i)*(i+1)
12301 C        print *, x(i+1),yy(i),i
12302       enddo
12303       gradtschebyshev=aux
12304       return
12305       end
12306 C------------------------------------------------------------------------
12307 C first for shielding is setting of function of side-chains
12308        subroutine set_shield_fac2
12309       implicit real*8 (a-h,o-z)
12310       include 'DIMENSIONS'
12311       include 'COMMON.CHAIN'
12312       include 'COMMON.DERIV'
12313       include 'COMMON.IOUNITS'
12314       include 'COMMON.SHIELD'
12315       include 'COMMON.INTERACT'
12316 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12317       double precision div77_81/0.974996043d0/,
12318      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12319
12320 C the vector between center of side_chain and peptide group
12321        double precision pep_side(3),long,side_calf(3),
12322      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12323      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12324 C the line belowe needs to be changed for FGPROC>1
12325       do i=1,nres-1
12326       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12327       ishield_list(i)=0
12328 Cif there two consequtive dummy atoms there is no peptide group between them
12329 C the line below has to be changed for FGPROC>1
12330       VolumeTotal=0.0
12331       do k=1,nres
12332        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12333        dist_pep_side=0.0
12334        dist_side_calf=0.0
12335        do j=1,3
12336 C first lets set vector conecting the ithe side-chain with kth side-chain
12337       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12338 C      pep_side(j)=2.0d0
12339 C and vector conecting the side-chain with its proper calfa
12340       side_calf(j)=c(j,k+nres)-c(j,k)
12341 C      side_calf(j)=2.0d0
12342       pept_group(j)=c(j,i)-c(j,i+1)
12343 C lets have their lenght
12344       dist_pep_side=pep_side(j)**2+dist_pep_side
12345       dist_side_calf=dist_side_calf+side_calf(j)**2
12346       dist_pept_group=dist_pept_group+pept_group(j)**2
12347       enddo
12348        dist_pep_side=dsqrt(dist_pep_side)
12349        dist_pept_group=dsqrt(dist_pept_group)
12350        dist_side_calf=dsqrt(dist_side_calf)
12351       do j=1,3
12352         pep_side_norm(j)=pep_side(j)/dist_pep_side
12353         side_calf_norm(j)=dist_side_calf
12354       enddo
12355 C now sscale fraction
12356        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12357 C       print *,buff_shield,"buff"
12358 C now sscale
12359         if (sh_frac_dist.le.0.0) cycle
12360 C If we reach here it means that this side chain reaches the shielding sphere
12361 C Lets add him to the list for gradient
12362         ishield_list(i)=ishield_list(i)+1
12363 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12364 C this list is essential otherwise problem would be O3
12365         shield_list(ishield_list(i),i)=k
12366 C Lets have the sscale value
12367         if (sh_frac_dist.gt.1.0) then
12368          scale_fac_dist=1.0d0
12369          do j=1,3
12370          sh_frac_dist_grad(j)=0.0d0
12371          enddo
12372         else
12373          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12374      &                   *(2.0d0*sh_frac_dist-3.0d0)
12375          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12376      &                  /dist_pep_side/buff_shield*0.5d0
12377 C remember for the final gradient multiply sh_frac_dist_grad(j)
12378 C for side_chain by factor -2 !
12379          do j=1,3
12380          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12381 C         sh_frac_dist_grad(j)=0.0d0
12382 C         scale_fac_dist=1.0d0
12383 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12384 C     &                    sh_frac_dist_grad(j)
12385          enddo
12386         endif
12387 C this is what is now we have the distance scaling now volume...
12388       short=short_r_sidechain(itype(k))
12389       long=long_r_sidechain(itype(k))
12390       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12391       sinthet=short/dist_pep_side*costhet
12392 C now costhet_grad
12393 C       costhet=0.6d0
12394 C       sinthet=0.8
12395        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12396 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12397 C     &             -short/dist_pep_side**2/costhet)
12398 C       costhet_fac=0.0d0
12399        do j=1,3
12400          costhet_grad(j)=costhet_fac*pep_side(j)
12401        enddo
12402 C remember for the final gradient multiply costhet_grad(j)
12403 C for side_chain by factor -2 !
12404 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12405 C pep_side0pept_group is vector multiplication
12406       pep_side0pept_group=0.0d0
12407       do j=1,3
12408       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12409       enddo
12410       cosalfa=(pep_side0pept_group/
12411      & (dist_pep_side*dist_side_calf))
12412       fac_alfa_sin=1.0d0-cosalfa**2
12413       fac_alfa_sin=dsqrt(fac_alfa_sin)
12414       rkprim=fac_alfa_sin*(long-short)+short
12415 C      rkprim=short
12416
12417 C now costhet_grad
12418        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12419 C       cosphi=0.6
12420        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12421        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12422      &      dist_pep_side**2)
12423 C       sinphi=0.8
12424        do j=1,3
12425          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12426      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12427      &*(long-short)/fac_alfa_sin*cosalfa/
12428      &((dist_pep_side*dist_side_calf))*
12429      &((side_calf(j))-cosalfa*
12430      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12431 C       cosphi_grad_long(j)=0.0d0
12432         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12433      &*(long-short)/fac_alfa_sin*cosalfa
12434      &/((dist_pep_side*dist_side_calf))*
12435      &(pep_side(j)-
12436      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12437 C       cosphi_grad_loc(j)=0.0d0
12438        enddo
12439 C      print *,sinphi,sinthet
12440 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12441 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12442       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12443      &                    /VSolvSphere_div
12444 C     &                    *wshield
12445 C now the gradient...
12446       do j=1,3
12447       grad_shield(j,i)=grad_shield(j,i)
12448 C gradient po skalowaniu
12449      &                +(sh_frac_dist_grad(j)*VofOverlap
12450 C  gradient po costhet
12451      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12452      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12453      &       sinphi/sinthet*costhet*costhet_grad(j)
12454      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12455      & )*wshield
12456 C grad_shield_side is Cbeta sidechain gradient
12457       grad_shield_side(j,ishield_list(i),i)=
12458      &        (sh_frac_dist_grad(j)*(-2.0d0)
12459      &        *VofOverlap
12460      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12461      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12462      &       sinphi/sinthet*costhet*costhet_grad(j)
12463      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12464      &       )*wshield
12465
12466        grad_shield_loc(j,ishield_list(i),i)=
12467      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12468      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12469      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12470      &        ))
12471      &        *wshield
12472       enddo
12473 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12474 c     & scale_fac_dist
12475       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12476       enddo
12477       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12478 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12479 c     &  " wshield",wshield
12480 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12481       enddo
12482       return
12483       end
12484 C-----------------------------------------------------------------------
12485 C-----------------------------------------------------------
12486 C This subroutine is to mimic the histone like structure but as well can be
12487 C utilizet to nanostructures (infinit) small modification has to be used to
12488 C make it finite (z gradient at the ends has to be changes as well as the x,y
12489 C gradient has to be modified at the ends
12490 C The energy function is Kihara potential
12491 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12492 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12493 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12494 C simple Kihara potential
12495       subroutine calctube(Etube)
12496        implicit real*8 (a-h,o-z)
12497       include 'DIMENSIONS'
12498       include 'COMMON.GEO'
12499       include 'COMMON.VAR'
12500       include 'COMMON.LOCAL'
12501       include 'COMMON.CHAIN'
12502       include 'COMMON.DERIV'
12503       include 'COMMON.NAMES'
12504       include 'COMMON.INTERACT'
12505       include 'COMMON.IOUNITS'
12506       include 'COMMON.CALC'
12507       include 'COMMON.CONTROL'
12508       include 'COMMON.SPLITELE'
12509       include 'COMMON.SBRIDGE'
12510       double precision tub_r,vectube(3),enetube(maxres*2)
12511       Etube=0.0d0
12512       do i=1,2*nres
12513         enetube(i)=0.0d0
12514       enddo
12515 C first we calculate the distance from tube center
12516 C first sugare-phosphate group for NARES this would be peptide group
12517 C for UNRES
12518       do i=1,nres
12519 C lets ommit dummy atoms for now
12520        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12521 C now calculate distance from center of tube and direction vectors
12522       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12523           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12524       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12525           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12526       vectube(1)=vectube(1)-tubecenter(1)
12527       vectube(2)=vectube(2)-tubecenter(2)
12528
12529 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12530 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12531
12532 C as the tube is infinity we do not calculate the Z-vector use of Z
12533 C as chosen axis
12534       vectube(3)=0.0d0
12535 C now calculte the distance
12536        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12537 C now normalize vector
12538       vectube(1)=vectube(1)/tub_r
12539       vectube(2)=vectube(2)/tub_r
12540 C calculte rdiffrence between r and r0
12541       rdiff=tub_r-tubeR0
12542 C and its 6 power
12543       rdiff6=rdiff**6.0d0
12544 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12545        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12546 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12547 C       print *,rdiff,rdiff6,pep_aa_tube
12548 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12549 C now we calculate gradient
12550        fac=(-12.0d0*pep_aa_tube/rdiff6+
12551      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12552 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12553 C     &rdiff,fac
12554
12555 C now direction of gg_tube vector
12556         do j=1,3
12557         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12558         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12559         enddo
12560         enddo
12561 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12562         do i=1,nres
12563 C Lets not jump over memory as we use many times iti
12564          iti=itype(i)
12565 C lets ommit dummy atoms for now
12566          if ((iti.eq.ntyp1)
12567 C in UNRES uncomment the line below as GLY has no side-chain...
12568 C      .or.(iti.eq.10)
12569      &   ) cycle
12570           vectube(1)=c(1,i+nres)
12571           vectube(1)=mod(vectube(1),boxxsize)
12572           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12573           vectube(2)=c(2,i+nres)
12574           vectube(2)=mod(vectube(2),boxxsize)
12575           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12576
12577       vectube(1)=vectube(1)-tubecenter(1)
12578       vectube(2)=vectube(2)-tubecenter(2)
12579
12580 C as the tube is infinity we do not calculate the Z-vector use of Z
12581 C as chosen axis
12582       vectube(3)=0.0d0
12583 C now calculte the distance
12584        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12585 C now normalize vector
12586       vectube(1)=vectube(1)/tub_r
12587       vectube(2)=vectube(2)/tub_r
12588 C calculte rdiffrence between r and r0
12589       rdiff=tub_r-tubeR0
12590 C and its 6 power
12591       rdiff6=rdiff**6.0d0
12592 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12593        sc_aa_tube=sc_aa_tube_par(iti)
12594        sc_bb_tube=sc_bb_tube_par(iti)
12595        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12596 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12597 C now we calculate gradient
12598        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12599      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12600 C now direction of gg_tube vector
12601          do j=1,3
12602           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12603           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12604          enddo
12605         enddo
12606         do i=1,2*nres
12607           Etube=Etube+enetube(i)
12608         enddo
12609 C        print *,"ETUBE", etube
12610         return
12611         end
12612 C TO DO 1) add to total energy
12613 C       2) add to gradient summation
12614 C       3) add reading parameters (AND of course oppening of PARAM file)
12615 C       4) add reading the center of tube
12616 C       5) add COMMONs
12617 C       6) add to zerograd
12618
12619 C-----------------------------------------------------------------------
12620 C-----------------------------------------------------------
12621 C This subroutine is to mimic the histone like structure but as well can be
12622 C utilizet to nanostructures (infinit) small modification has to be used to
12623 C make it finite (z gradient at the ends has to be changes as well as the x,y
12624 C gradient has to be modified at the ends
12625 C The energy function is Kihara potential
12626 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12627 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12628 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12629 C simple Kihara potential
12630       subroutine calctube2(Etube)
12631        implicit real*8 (a-h,o-z)
12632       include 'DIMENSIONS'
12633       include 'COMMON.GEO'
12634       include 'COMMON.VAR'
12635       include 'COMMON.LOCAL'
12636       include 'COMMON.CHAIN'
12637       include 'COMMON.DERIV'
12638       include 'COMMON.NAMES'
12639       include 'COMMON.INTERACT'
12640       include 'COMMON.IOUNITS'
12641       include 'COMMON.CALC'
12642       include 'COMMON.CONTROL'
12643       include 'COMMON.SPLITELE'
12644       include 'COMMON.SBRIDGE'
12645       double precision tub_r,vectube(3),enetube(maxres*2)
12646       Etube=0.0d0
12647       do i=1,2*nres
12648         enetube(i)=0.0d0
12649       enddo
12650 C first we calculate the distance from tube center
12651 C first sugare-phosphate group for NARES this would be peptide group
12652 C for UNRES
12653       do i=1,nres
12654 C lets ommit dummy atoms for now
12655        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12656 C now calculate distance from center of tube and direction vectors
12657       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12658           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12659       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12660           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12661       vectube(1)=vectube(1)-tubecenter(1)
12662       vectube(2)=vectube(2)-tubecenter(2)
12663
12664 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12665 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12666
12667 C as the tube is infinity we do not calculate the Z-vector use of Z
12668 C as chosen axis
12669       vectube(3)=0.0d0
12670 C now calculte the distance
12671        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12672 C now normalize vector
12673       vectube(1)=vectube(1)/tub_r
12674       vectube(2)=vectube(2)/tub_r
12675 C calculte rdiffrence between r and r0
12676       rdiff=tub_r-tubeR0
12677 C and its 6 power
12678       rdiff6=rdiff**6.0d0
12679 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12680        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12681 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12682 C       print *,rdiff,rdiff6,pep_aa_tube
12683 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12684 C now we calculate gradient
12685        fac=(-12.0d0*pep_aa_tube/rdiff6+
12686      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12687 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12688 C     &rdiff,fac
12689
12690 C now direction of gg_tube vector
12691         do j=1,3
12692         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12693         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12694         enddo
12695         enddo
12696 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12697         do i=1,nres
12698 C Lets not jump over memory as we use many times iti
12699          iti=itype(i)
12700 C lets ommit dummy atoms for now
12701          if ((iti.eq.ntyp1)
12702 C in UNRES uncomment the line below as GLY has no side-chain...
12703      &      .or.(iti.eq.10)
12704      &   ) cycle
12705           vectube(1)=c(1,i+nres)
12706           vectube(1)=mod(vectube(1),boxxsize)
12707           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12708           vectube(2)=c(2,i+nres)
12709           vectube(2)=mod(vectube(2),boxxsize)
12710           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12711
12712       vectube(1)=vectube(1)-tubecenter(1)
12713       vectube(2)=vectube(2)-tubecenter(2)
12714 C THIS FRAGMENT MAKES TUBE FINITE
12715         positi=(mod(c(3,i+nres),boxzsize))
12716         if (positi.le.0) positi=positi+boxzsize
12717 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12718 c for each residue check if it is in lipid or lipid water border area
12719 C       respos=mod(c(3,i+nres),boxzsize)
12720        print *,positi,bordtubebot,buftubebot,bordtubetop
12721        if ((positi.gt.bordtubebot)
12722      & .and.(positi.lt.bordtubetop)) then
12723 C the energy transfer exist
12724         if (positi.lt.buftubebot) then
12725          fracinbuf=1.0d0-
12726      &     ((positi-bordtubebot)/tubebufthick)
12727 C lipbufthick is thickenes of lipid buffore
12728          sstube=sscalelip(fracinbuf)
12729          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12730          print *,ssgradtube, sstube,tubetranene(itype(i))
12731          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12732          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12733      &+ssgradtube*tubetranene(itype(i))
12734          gg_tube(3,i-1)= gg_tube(3,i-1)
12735      &+ssgradtube*tubetranene(itype(i))
12736 C         print *,"doing sccale for lower part"
12737         elseif (positi.gt.buftubetop) then
12738          fracinbuf=1.0d0-
12739      &((bordtubetop-positi)/tubebufthick)
12740          sstube=sscalelip(fracinbuf)
12741          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12742          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12743 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12744 C     &+ssgradtube*tubetranene(itype(i))
12745 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12746 C     &+ssgradtube*tubetranene(itype(i))
12747 C          print *, "doing sscalefor top part",sslip,fracinbuf
12748         else
12749          sstube=1.0d0
12750          ssgradtube=0.0d0
12751          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12752 C         print *,"I am in true lipid"
12753         endif
12754         else
12755 C          sstube=0.0d0
12756 C          ssgradtube=0.0d0
12757         cycle
12758         endif ! if in lipid or buffor
12759 CEND OF FINITE FRAGMENT
12760 C as the tube is infinity we do not calculate the Z-vector use of Z
12761 C as chosen axis
12762       vectube(3)=0.0d0
12763 C now calculte the distance
12764        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12765 C now normalize vector
12766       vectube(1)=vectube(1)/tub_r
12767       vectube(2)=vectube(2)/tub_r
12768 C calculte rdiffrence between r and r0
12769       rdiff=tub_r-tubeR0
12770 C and its 6 power
12771       rdiff6=rdiff**6.0d0
12772 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12773        sc_aa_tube=sc_aa_tube_par(iti)
12774        sc_bb_tube=sc_bb_tube_par(iti)
12775        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12776      &                 *sstube+enetube(i+nres)
12777 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12778 C now we calculate gradient
12779        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12780      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12781 C now direction of gg_tube vector
12782          do j=1,3
12783           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12784           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12785          enddo
12786          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12787      &+ssgradtube*enetube(i+nres)/sstube
12788          gg_tube(3,i-1)= gg_tube(3,i-1)
12789      &+ssgradtube*enetube(i+nres)/sstube
12790
12791         enddo
12792         do i=1,2*nres
12793           Etube=Etube+enetube(i)
12794         enddo
12795 C        print *,"ETUBE", etube
12796         return
12797         end
12798 C TO DO 1) add to total energy
12799 C       2) add to gradient summation
12800 C       3) add reading parameters (AND of course oppening of PARAM file)
12801 C       4) add reading the center of tube
12802 C       5) add COMMONs
12803 C       6) add to zerograd
12804 c----------------------------------------------------------------------------
12805       subroutine e_saxs(Esaxs_constr)
12806       implicit none
12807       include 'DIMENSIONS'
12808 #ifdef MPI
12809       include "mpif.h"
12810       include "COMMON.SETUP"
12811       integer IERR
12812 #endif
12813       include 'COMMON.SBRIDGE'
12814       include 'COMMON.CHAIN'
12815       include 'COMMON.GEO'
12816       include 'COMMON.DERIV'
12817       include 'COMMON.LOCAL'
12818       include 'COMMON.INTERACT'
12819       include 'COMMON.VAR'
12820       include 'COMMON.IOUNITS'
12821 c      include 'COMMON.MD'
12822 #ifdef LANG0
12823 #ifdef FIVEDIAG
12824       include 'COMMON.LANGEVIN.lang0.5diag'
12825 #else
12826       include 'COMMON.LANGEVIN.lang0'
12827 #endif
12828 #else
12829       include 'COMMON.LANGEVIN'
12830 #endif
12831       include 'COMMON.CONTROL'
12832       include 'COMMON.SAXS'
12833       include 'COMMON.NAMES'
12834       include 'COMMON.TIME1'
12835       include 'COMMON.FFIELD'
12836 c
12837       double precision Esaxs_constr
12838       integer i,iint,j,k,l
12839       double precision PgradC(maxSAXS,3,maxres),
12840      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12841 #ifdef MPI
12842       double precision PgradC_(maxSAXS,3,maxres),
12843      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12844 #endif
12845       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12846      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12847      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12848      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12849       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12850       double precision dist,mygauss,mygaussder
12851       external dist
12852       integer llicz,lllicz
12853       double precision time01
12854 c  SAXS restraint penalty function
12855 #ifdef DEBUG
12856       write(iout,*) "------- SAXS penalty function start -------"
12857       write (iout,*) "nsaxs",nsaxs
12858       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12859       write (iout,*) "Psaxs"
12860       do i=1,nsaxs
12861         write (iout,'(i5,e15.5)') i, Psaxs(i)
12862       enddo
12863 #endif
12864 #ifdef TIMING
12865       time01=MPI_Wtime()
12866 #endif
12867       Esaxs_constr = 0.0d0
12868       do k=1,nsaxs
12869         Pcalc(k)=0.0d0
12870         do j=1,nres
12871           do l=1,3
12872             PgradC(k,l,j)=0.0d0
12873             PgradX(k,l,j)=0.0d0
12874           enddo
12875         enddo
12876       enddo
12877 c      lllicz=0
12878       do i=iatsc_s,iatsc_e
12879        if (itype(i).eq.ntyp1) cycle
12880        do iint=1,nint_gr(i)
12881          do j=istart(i,iint),iend(i,iint)
12882            if (itype(j).eq.ntyp1) cycle
12883 #ifdef ALLSAXS
12884            dijCACA=dist(i,j)
12885            dijCASC=dist(i,j+nres)
12886            dijSCCA=dist(i+nres,j)
12887            dijSCSC=dist(i+nres,j+nres)
12888            sigma2CACA=2.0d0/(pstok**2)
12889            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12890            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12891            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12892            do k=1,nsaxs
12893              dk = distsaxs(k)
12894              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12895              if (itype(j).ne.10) then
12896              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12897              else
12898              endif
12899              expCASC = 0.0d0
12900              if (itype(i).ne.10) then
12901              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12902              else
12903              expSCCA = 0.0d0
12904              endif
12905              if (itype(i).ne.10 .and. itype(j).ne.10) then
12906              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12907              else
12908              expSCSC = 0.0d0
12909              endif
12910              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12911 #ifdef DEBUG
12912              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12913 #endif
12914              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12915              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12916              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12917              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12918              do l=1,3
12919 c CA CA
12920                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12921                PgradC(k,l,i) = PgradC(k,l,i)-aux
12922                PgradC(k,l,j) = PgradC(k,l,j)+aux
12923 c CA SC
12924                if (itype(j).ne.10) then
12925                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12926                PgradC(k,l,i) = PgradC(k,l,i)-aux
12927                PgradC(k,l,j) = PgradC(k,l,j)+aux
12928                PgradX(k,l,j) = PgradX(k,l,j)+aux
12929                endif
12930 c SC CA
12931                if (itype(i).ne.10) then
12932                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12933                PgradX(k,l,i) = PgradX(k,l,i)-aux
12934                PgradC(k,l,i) = PgradC(k,l,i)-aux
12935                PgradC(k,l,j) = PgradC(k,l,j)+aux
12936                endif
12937 c SC SC
12938                if (itype(i).ne.10 .and. itype(j).ne.10) then
12939                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12940                PgradC(k,l,i) = PgradC(k,l,i)-aux
12941                PgradC(k,l,j) = PgradC(k,l,j)+aux
12942                PgradX(k,l,i) = PgradX(k,l,i)-aux
12943                PgradX(k,l,j) = PgradX(k,l,j)+aux
12944                endif
12945              enddo ! l
12946            enddo ! k
12947 #else
12948            dijCACA=dist(i,j)
12949            sigma2CACA=scal_rad**2*0.25d0/
12950      &        (restok(itype(j))**2+restok(itype(i))**2)
12951 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12952 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12953 #ifdef MYGAUSS
12954            sigmaCACA=dsqrt(sigma2CACA)
12955            threesig=3.0d0/sigmaCACA
12956 c           llicz=0
12957            do k=1,nsaxs
12958              dk = distsaxs(k)
12959              if (dabs(dijCACA-dk).ge.threesig) cycle
12960 c             llicz=llicz+1
12961 c             lllicz=lllicz+1
12962              aux = sigmaCACA*(dijCACA-dk)
12963              expCACA = mygauss(aux)
12964 c             if (expcaca.eq.0.0d0) cycle
12965              Pcalc(k) = Pcalc(k)+expCACA
12966              CACAgrad = -sigmaCACA*mygaussder(aux)
12967 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12968              do l=1,3
12969                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12970                PgradC(k,l,i) = PgradC(k,l,i)-aux
12971                PgradC(k,l,j) = PgradC(k,l,j)+aux
12972              enddo ! l
12973            enddo ! k
12974 c           write (iout,*) "i",i," j",j," llicz",llicz
12975 #else
12976            IF (saxs_cutoff.eq.0) THEN
12977            do k=1,nsaxs
12978              dk = distsaxs(k)
12979              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12980              Pcalc(k) = Pcalc(k)+expCACA
12981              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12982              do l=1,3
12983                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12984                PgradC(k,l,i) = PgradC(k,l,i)-aux
12985                PgradC(k,l,j) = PgradC(k,l,j)+aux
12986              enddo ! l
12987            enddo ! k
12988            ELSE
12989            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12990            do k=1,nsaxs
12991              dk = distsaxs(k)
12992 c             write (2,*) "ijk",i,j,k
12993              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12994              if (sss2.eq.0.0d0) cycle
12995              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12996              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12997      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12998      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
12999      &           sss2,ssgrad2
13000              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13001              Pcalc(k) = Pcalc(k)+expCACA
13002 #ifdef DEBUG
13003              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13004 #endif
13005              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13006      &             ssgrad2*expCACA/sss2
13007              do l=1,3
13008 c CA CA
13009                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13010                PgradC(k,l,i) = PgradC(k,l,i)+aux
13011                PgradC(k,l,j) = PgradC(k,l,j)-aux
13012              enddo ! l
13013            enddo ! k
13014            ENDIF
13015 #endif
13016 #endif
13017          enddo ! j
13018        enddo ! iint
13019       enddo ! i
13020 c#ifdef TIMING
13021 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13022 c#endif
13023 c      write (iout,*) "lllicz",lllicz
13024 c#ifdef TIMING
13025 c      time01=MPI_Wtime()
13026 c#endif
13027 #ifdef MPI
13028       if (nfgtasks.gt.1) then
13029        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13030      &    MPI_SUM,FG_COMM,IERR)
13031 c        if (fg_rank.eq.king) then
13032           do k=1,nsaxs
13033             Pcalc(k) = Pcalc_(k)
13034           enddo
13035 c        endif
13036 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13037 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13038 c        if (fg_rank.eq.king) then
13039 c          do i=1,nres
13040 c            do l=1,3
13041 c              do k=1,nsaxs
13042 c                PgradC(k,l,i) = PgradC_(k,l,i)
13043 c              enddo
13044 c            enddo
13045 c          enddo
13046 c        endif
13047 #ifdef ALLSAXS
13048 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13049 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13050 c        if (fg_rank.eq.king) then
13051 c          do i=1,nres
13052 c            do l=1,3
13053 c              do k=1,nsaxs
13054 c                PgradX(k,l,i) = PgradX_(k,l,i)
13055 c              enddo
13056 c            enddo
13057 c          enddo
13058 c        endif
13059 #endif
13060       endif
13061 #endif
13062       Cnorm = 0.0d0
13063       do k=1,nsaxs
13064         Cnorm = Cnorm + Pcalc(k)
13065       enddo
13066 #ifdef MPI
13067       if (fg_rank.eq.king) then
13068 #endif
13069       Esaxs_constr = dlog(Cnorm)-wsaxs0
13070       do k=1,nsaxs
13071         if (Pcalc(k).gt.0.0d0)
13072      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13073 #ifdef DEBUG
13074         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13075 #endif
13076       enddo
13077 #ifdef DEBUG
13078       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13079 #endif
13080 #ifdef MPI
13081       endif
13082 #endif
13083       gsaxsC=0.0d0
13084       gsaxsX=0.0d0
13085       do i=nnt,nct
13086         do l=1,3
13087           auxC=0.0d0
13088           auxC1=0.0d0
13089           auxX=0.0d0
13090           auxX1=0.d0
13091           do k=1,nsaxs
13092             if (Pcalc(k).gt.0)
13093      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13094             auxC1 = auxC1+PgradC(k,l,i)
13095 #ifdef ALLSAXS
13096             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13097             auxX1 = auxX1+PgradX(k,l,i)
13098 #endif
13099           enddo
13100           gsaxsC(l,i) = auxC - auxC1/Cnorm
13101 #ifdef ALLSAXS
13102           gsaxsX(l,i) = auxX - auxX1/Cnorm
13103 #endif
13104 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13105 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13106 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13107 c     *     " gradX",wsaxs*gsaxsX(l,i)
13108         enddo
13109       enddo
13110 #ifdef TIMING
13111       time_SAXS=time_SAXS+MPI_Wtime()-time01
13112 #endif
13113 #ifdef DEBUG
13114       write (iout,*) "gsaxsc"
13115       do i=nnt,nct
13116         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13117       enddo
13118 #endif
13119 #ifdef MPI
13120 c      endif
13121 #endif
13122       return
13123       end
13124 c----------------------------------------------------------------------------
13125       subroutine e_saxsC(Esaxs_constr)
13126       implicit none
13127       include 'DIMENSIONS'
13128 #ifdef MPI
13129       include "mpif.h"
13130       include "COMMON.SETUP"
13131       integer IERR
13132 #endif
13133       include 'COMMON.SBRIDGE'
13134       include 'COMMON.CHAIN'
13135       include 'COMMON.GEO'
13136       include 'COMMON.DERIV'
13137       include 'COMMON.LOCAL'
13138       include 'COMMON.INTERACT'
13139       include 'COMMON.VAR'
13140       include 'COMMON.IOUNITS'
13141 c      include 'COMMON.MD'
13142 #ifdef LANG0
13143 #ifdef FIVEDIAG
13144       include 'COMMON.LANGEVIN.lang0.5diag'
13145 #else
13146       include 'COMMON.LANGEVIN.lang0'
13147 #endif
13148 #else
13149       include 'COMMON.LANGEVIN'
13150 #endif
13151       include 'COMMON.CONTROL'
13152       include 'COMMON.SAXS'
13153       include 'COMMON.NAMES'
13154       include 'COMMON.TIME1'
13155       include 'COMMON.FFIELD'
13156 c
13157       double precision Esaxs_constr
13158       integer i,iint,j,k,l
13159       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13160 #ifdef MPI
13161       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13162 #endif
13163       double precision dk,dijCASPH,dijSCSPH,
13164      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13165      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13166      & auxX,auxX1,Cnorm
13167 c  SAXS restraint penalty function
13168 #ifdef DEBUG
13169       write(iout,*) "------- SAXS penalty function start -------"
13170       write (iout,*) "nsaxs",nsaxs
13171
13172       do i=nnt,nct
13173         print *,MyRank,"C",i,(C(j,i),j=1,3)
13174       enddo
13175       do i=nnt,nct
13176         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13177       enddo
13178 #endif
13179       Esaxs_constr = 0.0d0
13180       logPtot=0.0d0
13181       do j=isaxs_start,isaxs_end
13182         Pcalc=0.0d0
13183         do i=1,nres
13184           do l=1,3
13185             PgradC(l,i)=0.0d0
13186             PgradX(l,i)=0.0d0
13187           enddo
13188         enddo
13189         do i=nnt,nct
13190           if (itype(i).eq.ntyp1) cycle
13191           dijCASPH=0.0d0
13192           dijSCSPH=0.0d0
13193           do l=1,3
13194             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13195           enddo
13196           if (itype(i).ne.10) then
13197           do l=1,3
13198             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13199           enddo
13200           endif
13201           sigma2CA=2.0d0/pstok**2
13202           sigma2SC=4.0d0/restok(itype(i))**2
13203           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13204           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13205           Pcalc = Pcalc+expCASPH+expSCSPH
13206 #ifdef DEBUG
13207           write(*,*) "processor i j Pcalc",
13208      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13209 #endif
13210           CASPHgrad = sigma2CA*expCASPH
13211           SCSPHgrad = sigma2SC*expSCSPH
13212           do l=1,3
13213             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13214             PgradX(l,i) = PgradX(l,i) + aux
13215             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13216           enddo ! l
13217         enddo ! i
13218         do i=nnt,nct
13219           do l=1,3
13220             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13221             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13222           enddo
13223         enddo
13224         logPtot = logPtot - dlog(Pcalc)
13225 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13226 c     &    " logPtot",logPtot
13227       enddo ! j
13228 #ifdef MPI
13229       if (nfgtasks.gt.1) then
13230 c        write (iout,*) "logPtot before reduction",logPtot
13231         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13232      &    MPI_SUM,king,FG_COMM,IERR)
13233         logPtot = logPtot_
13234 c        write (iout,*) "logPtot after reduction",logPtot
13235         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13236      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13237         if (fg_rank.eq.king) then
13238           do i=1,nres
13239             do l=1,3
13240               gsaxsC(l,i) = gsaxsC_(l,i)
13241             enddo
13242           enddo
13243         endif
13244         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13245      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13246         if (fg_rank.eq.king) then
13247           do i=1,nres
13248             do l=1,3
13249               gsaxsX(l,i) = gsaxsX_(l,i)
13250             enddo
13251           enddo
13252         endif
13253       endif
13254 #endif
13255       Esaxs_constr = logPtot
13256       return
13257       end
13258 c----------------------------------------------------------------------------
13259       double precision function sscale2(r,r_cut,r0,rlamb)
13260       implicit none
13261       double precision r,gamm,r_cut,r0,rlamb,rr
13262       rr = dabs(r-r0)
13263 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13264 c      write (2,*) "rr",rr
13265       if(rr.lt.r_cut-rlamb) then
13266         sscale2=1.0d0
13267       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13268         gamm=(rr-(r_cut-rlamb))/rlamb
13269         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13270       else
13271         sscale2=0d0
13272       endif
13273       return
13274       end
13275 C-----------------------------------------------------------------------
13276       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13277       implicit none
13278       double precision r,gamm,r_cut,r0,rlamb,rr
13279       rr = dabs(r-r0)
13280       if(rr.lt.r_cut-rlamb) then
13281         sscalgrad2=0.0d0
13282       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13283         gamm=(rr-(r_cut-rlamb))/rlamb
13284         if (r.ge.r0) then
13285           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13286         else
13287           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13288         endif
13289       else
13290         sscalgrad2=0.0d0
13291       endif
13292       return
13293       end
13294 c------------------------------------------------------------------------
13295       double precision function boxshift(x,boxsize)
13296       implicit none
13297       double precision x,boxsize
13298       double precision xtemp
13299       xtemp=dmod(x,boxsize)
13300       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
13301         boxshift=xtemp-boxsize
13302       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
13303         boxshift=xtemp+boxsize
13304       else
13305         boxshift=xtemp
13306       endif
13307       return
13308       end
13309 c--------------------------------------------------------------------------
13310       subroutine closest_img(xi,yi,zi,xj,yj,zj)
13311       include 'DIMENSIONS'
13312       include 'COMMON.CHAIN'
13313       integer xshift,yshift,zshift,subchap
13314       double precision dist_init,xj_safe,yj_safe,zj_safe,
13315      & xj_temp,yj_temp,zj_temp,dist_temp
13316       xj_safe=xj
13317       yj_safe=yj
13318       zj_safe=zj
13319       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13320       subchap=0
13321       do xshift=-1,1
13322         do yshift=-1,1
13323           do zshift=-1,1
13324             xj=xj_safe+xshift*boxxsize
13325             yj=yj_safe+yshift*boxysize
13326             zj=zj_safe+zshift*boxzsize
13327             dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13328             if(dist_temp.lt.dist_init) then
13329               dist_init=dist_temp
13330               xj_temp=xj
13331               yj_temp=yj
13332               zj_temp=zj
13333               subchap=1
13334             endif
13335           enddo
13336         enddo
13337       enddo
13338       if (subchap.eq.1) then
13339         xj=xj_temp-xi
13340         yj=yj_temp-yi
13341         zj=zj_temp-zi
13342       else
13343         xj=xj_safe-xi
13344         yj=yj_safe-yi
13345         zj=zj_safe-zi
13346       endif
13347       return
13348       end
13349 c--------------------------------------------------------------------------
13350       subroutine to_box(xi,yi,zi)
13351       implicit none
13352       include 'DIMENSIONS'
13353       include 'COMMON.CHAIN'
13354       double precision xi,yi,zi
13355       xi=dmod(xi,boxxsize)
13356       if (xi.lt.0.0d0) xi=xi+boxxsize
13357       yi=dmod(yi,boxysize)
13358       if (yi.lt.0.0d0) yi=yi+boxysize
13359       zi=dmod(zi,boxzsize)
13360       if (zi.lt.0.0d0) zi=zi+boxzsize
13361       return
13362       end
13363 c--------------------------------------------------------------------------
13364       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13365       implicit none
13366       include 'DIMENSIONS'
13367       include 'COMMON.IOUNITS'
13368       include 'COMMON.CHAIN'
13369       double precision xi,yi,zi,sslipi,ssgradlipi
13370       double precision fracinbuf
13371       double precision sscalelip,sscagradlip
13372 #ifdef DEBUG
13373       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
13374       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
13375       write (iout,*) "xi yi zi",xi,yi,zi
13376 #endif
13377       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
13378 C the energy transfer exist
13379         if (zi.lt.buflipbot) then
13380 C what fraction I am in
13381           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
13382 C lipbufthick is thickenes of lipid buffore
13383           sslipi=sscalelip(fracinbuf)
13384           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13385         elseif (zi.gt.bufliptop) then
13386           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13387           sslipi=sscalelip(fracinbuf)
13388           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13389         else
13390           sslipi=1.0d0
13391           ssgradlipi=0.0
13392         endif
13393       else
13394         sslipi=0.0d0
13395         ssgradlipi=0.0
13396       endif
13397 #ifdef DEBUG
13398       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
13399 #endif
13400       return
13401       end